analyze_detail_stat_.pl1        08/18/86  1311.9rew 08/18/86  1310.3      798129



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

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

analyze_detail_stat_:
     proc (dev_name, iom_stats, det_stats, auto_analp, code);

/*  Completed for installation May, 1981 by Rich Coppola */
/*  Modified Apr 12, 1982 by Rich Coppola to add support for STC tape drives and
   PR54 */
/* Modified September 1982 by C. Hornig for new PRPH TAP config card. */
/*  Modified Oct 1982 by Rich Coppola to fix bugs in initialization of variables
   used by the rs and rsnnl entries and in their return.  Also added code to
   decode byte 10 and 11 of disk detail status now that all of it is available.
   The calling sequence to the rs and rsnnl had to be changed by the way.

   Modified Oct 1983 by Paul Farley to change tape analysis to conform to
   io_log_status_info.cds. Also changed tracks_in_error to be sorted by track.
   Modified Feb. 1985 by Paul Farley to check for null ptrs from find_config_card_.
   Modified June 1985 by Paul Farley to handle FIPS tape & disk, and
   to handle PR54 if it is configed as a PR71. Also removed support of DSU190(A&B).
*/
/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-18,Coppola), install(86-03-21,MR12.0-1033):
     Support FIPS.
  2) change(86-08-05,Farley), approve(86-08-05,MCR6979),
     audit(86-08-08,Fawcett), install(86-08-18,MR12.0-1125):
     Post bug fix to look for an IPC card instead of a FIPS card.
                                                   END HISTORY COMMENTS */

dcl  iom_stats bit (36) aligned,
     dev_name char (*),				/* the name of the device */
     det_stats bit (*) unal,
     auto_analp ptr,
     message char (256) var,				/* return STR for rs and rsnnl entries */
     is_interesting bit (1),
     code fixed bin (35);

/* External */

dcl  config_deck$ ext;
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  error_table_$no_r_permission fixed bin (35) ext static;
dcl  error_table_$resource_unknown fixed bin (35) ext static;
dcl  error_table_$resource_type_inappropriate fixed bin (35) ext static;
dcl  error_table_$unimplemented_version fixed bin (35) ext static;
dcl  error_table_$bad_arg fixed bin (35) ext static;
dcl  error_table_$request_not_recognized fixed bin (35) ext static;
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  ioa_$rsnnl entry () options (variable);
dcl  config_$find entry (char (4) aligned, ptr);
dcl  config_$find_periph entry (char (4) aligned, ptr);

dcl  1 status aligned based (statp),
       2 stat_pad bit (2) unal,
       2 stat_maj bit (4) unal,
       2 stat_min bit (6) unal,
       2 stat_pad1 bit (4) unal,
       2 stat_init bit (1) unal,
       2 stat_pad2 bit (1) unal,
       2 stat_chan bit (3) unal,
       2 stat_cent bit (3) unal,
       2 stat_pad3 bit (48) unal;


dcl  statp ptr;

dcl  (i, j) fixed bin;
dcl  name char (7) var;
dcl  a_is_interesting bit (1) init ("0"b);		/* det. stat has data of import */
dcl  fips_controller bit (1);
dcl  (number_analyzed, anlzd) fixed bin;		/* number of bits analyzed */
dcl  mode fixed bin (5);
dcl  ret_str char (20) var init ("");			/* return string for ioa_$rsnnl */

dcl  1 a_tape_analysis,
       2 mth_model char (8),
       2 num_tracks fixed bin,
       2 trks_in_err char (18),
       2 dbie_array (9) fixed bin,
       2 modes,
         3 density fixed bin,
         3 operation char (6) var,			/* write/read/rew */
       2 anal (50) char (65) var;

dcl  1 a_disk_analysis,
       2 dsk_model char (7) var,
       2 CA fixed bin,
       2 PORT fixed bin,
       2 analyses (50) char (50) var;

dcl  1 a_prt_analysis,
       2 prt_model char (7) var,
       2 density char (6),				/* 6/8 lpi */
       2 analyses (50) char (40) var;

dcl  1 a_rdr_pun_analysis,
       2 rdr_pun_model char (6),
       2 analyses (60) char (40) var;

dcl  (rs_sw, rsnnl_sw) bit (1) init ("0"b);
dcl  xcode fixed bin (35);
dcl  NEW_LINE char (1) internal static options (constant) init ("
");
dcl  (addr, bin, bool, char, fixed, hbound, ltrim, rtrim, substr, null, bit) builtin;

%page;
	auto_analp = null ();
	go to START;				/* bypass rs and rsnnl entries */


analyze_detail_stat_$rsnnl:
     entry (dev_name, iom_stats, det_stats, message, is_interesting, code);

	rsnnl_sw = "1"b;
	go to START;

analyze_detail_stat_$rs:
     entry (dev_name, iom_stats, det_stats, message, is_interesting, code);

	rs_sw = "1"b;

START:
	number_analyzed, code = 0;			/* initialize */
	a_is_interesting = "0"b;

	if (rs_sw | rsnnl_sw) then do;
	     is_interesting = "0"b;
	     message = "";
	     end;


	if iom_stats = "0"b then do;			/* validate iom status */
	     code = error_table_$bad_arg;
	     return;
	     end;

	if det_stats = "0"b then do;			/* and detail status */
	     code = error_table_$bad_arg;
	     return;
	     end;


/* check callers access to the config_deck, without it can do nothing for him */


	call hcs_$fs_get_mode (addr (config_deck$), mode, code);
	if code ^= 0 then return;
	if (bit (mode) & bit (R_ACCESS_BIN)) ^= bit (R_ACCESS_BIN) then do;
	     code = error_table_$no_r_permission;
	     return;
	     end;


	name = dev_name;

	if substr (name, 1, 3) = "tap" then call anal_tape_;

	else if substr (name, 1, 3) = "dsk" then call anal_disk_;

	else if substr (name, 1, 3) = "prt" then call anal_prt_;

	else if substr (name, 1, 3) = "rdr" then call anal_rdr_pun;

	else if substr (name, 1, 3) = "pun" then call anal_rdr_pun;



	else do;
	     code = error_table_$resource_type_inappropriate;
	     return;
	     end;

	return;

%page;
anal_disk_:
     proc;

dcl  dev_no fixed bin (35);
dcl  dev_model fixed bin;
dcl  dev_no_index fixed bin;
dcl  temp_dsk_det_stats bit (47) init ("0"b);

dcl  trans_table_dsu451 (29) char (45) varying int static options (constant)
	init ("DLI Fault. ", "Device Protected. ", "Device Fault. ", "In Diagnostic Mode. ", "Command Parity Error. ",
	"Invalid Command. ", "Invalid Command Sequence. ", "State Violation. ", "Protect Violation. ",
	"Transfer Timing Error. ", "Data Parity Error. ", "Loss of Write Current. ",
	"Write Current & NO Write Command. ", "Loss of AC Write Current. ", "No or Multiple Head Select. ",
	"Spindle Speed Loss. ", "DC Power Loss. ", "Seek Incomplete. ", "Positioner Overtravel. ", "RPS Error. ",
	"1st Seek Cycle Incomplete. ", "Loss of Cooling. ", "Heads Retracted. ", "Positioner Offset. ",
	"Read Clock Offset. ", "Write AND Read Set. ", "Fine Servo. ", "Forward FF Set. ", "Reverse FF Set. ");


dcl  trans_table_dsu5xx (25) char (45) varying int static options (constant)
	init ("DLI Fault. ", "Device Protected. ", "Device Fault. ", "In Diagnostic Mode. ", "Command Parity Error. ",
	"Invalid Command. ", "Invalid Command Sequence. ", "State Violation. ", "Protect Violation. ",
	"Transfer Timing Error. ", "Data Parity Error. ", "Loss of Write Current. ",
	"Write Current & NO Write Command. ", "Loss of AC Write Current. ", "No or Multiple Head Select. ",
	"Spindle Speed Loss. ", "Seek Incomplete. ", "RPS Error. ", "Servo off Track. ", "Access Check. ",
	"Pack Unsafe. ", "Index Check. ", "Read AND Write Check. ", "Inhibit HDA Cycle. ", "HDA Sequence Check. ");


	a_disk_analysis.dsk_model = "";
	a_disk_analysis.CA = fixed (substr (det_stats, 80, 1), 1);
	a_disk_analysis.PORT = fixed (substr (det_stats, 84, 5), 5);
	a_disk_analysis.analyses (*) = "";
	anlzd = 0;
	statp = addr (iom_stats);
	temp_dsk_det_stats = "0"b;
	dev_no = cv_dec_check_ (substr (name, 6, 2), code);
						/* will need drive no. later */


/* Check iom status to see if detail status is worth analyzing */

	if stat_maj = "1101"b |			/* MPC cmd rej */
	     stat_maj = "0101"b |			/* dev cmd rej */
	     stat_maj = "0100"b |			/* EOFs */
	     stat_maj = "0001"b |			/* dev busy */
	     stat_maj = "0000"b then do;		/* Ready */

/* detail status is either not available or not worthy of analysis, return */


	     anlzd = 0;
	     code = error_table_$request_not_recognized;
	     return;
	     end;


/* Now determine the model of the drive  */


	dev_no_index, dev_model = 0;
	prph_dsk_cardp = null ();
	call config_$find_periph (substr (name, 1, 4), prph_dsk_cardp);
	if prph_dsk_cardp = null () then do;
	     code = error_table_$resource_unknown;
	     return;
	     end;

	call find_controller (prph_dsk_card.iom, prph_dsk_card.chan);
	if mpc_cardp = null () & ipc_cardp = null () then return;
						/* not MPC/FIPS driven */
	do j = 1 to 5 while (dev_model = 0);
	     dev_no_index = dev_no_index + prph_dsk_card.ndrives (j);
	     if dev_no < dev_no_index | (^fips_controller & dev_no = dev_no_index)
	     then dev_model = prph_dsk_card.model (j);
	end;

	if fips_controller then do;			/* handle fips differently */
	     call anal_fips_disk_;
	     goto fill_dsk_struct;
	     end;

	if dev_model = 450 | dev_model = 451
	then					/* go do it */
	     go to type_451;

	else if dev_model = 500 | dev_model = 501 then go to type_5xx;


/* If none of the above, then device type is unknown, therefore... */


	code = error_table_$resource_type_inappropriate;
	return;

type_451:
	a_disk_analysis.dsk_model = "DSU451";


/* set up to look at interesting bits only */

	substr (temp_dsk_det_stats, 1, 5) = substr (det_stats, 5, 5);
	substr (temp_dsk_det_stats, 6, 10) = substr (det_stats, 11, 10);
	substr (temp_dsk_det_stats, 16, 1) = substr (det_stats, 22, 1);
	substr (temp_dsk_det_stats, 17, 3) = substr (det_stats, 24, 3);
	substr (temp_dsk_det_stats, 20, 1) = substr (det_stats, 29, 1);
	substr (temp_dsk_det_stats, 21, 1) = substr (det_stats, 36, 1);
	substr (temp_dsk_det_stats, 22, 1) = substr (det_stats, 38, 1);
	substr (temp_dsk_det_stats, 23, 4) = substr (det_stats, 45, 4);
	substr (temp_dsk_det_stats, 27, 1) = substr (det_stats, 33, 1);
	substr (temp_dsk_det_stats, 28, 2) = substr (det_stats, 39, 2);


	do i = 1 to 29;
	     if substr (temp_dsk_det_stats, i, 1) then do;
		anlzd = anlzd + 1;
		a_disk_analysis.analyses (anlzd) = trans_table_dsu451 (i);
		a_is_interesting = "1"b;
		end;
	end;


	if (stat_maj ^= "0010"b)
	then if (substr (det_stats, 4, 1) & substr (det_stats, 33, 1)) then do;
		anlzd = anlzd + 1;
		a_disk_analysis.analyses (anlzd) = "Positioner busy AND data Xfer.";

		anlzd = anlzd + 1;
		a_disk_analysis.analyses (anlzd) = "(POSSIBLE actuator problem).";
		a_is_interesting = "1"b;
		end;


	go to fill_dsk_struct;

type_5xx:
	a_disk_analysis.dsk_model = "MSU" || ltrim (char (dev_model));

	substr (temp_dsk_det_stats, 1, 5) = substr (det_stats, 5, 5);
	substr (temp_dsk_det_stats, 6, 10) = substr (det_stats, 11, 10);
	substr (temp_dsk_det_stats, 16, 1) = substr (det_stats, 22, 1);
	substr (temp_dsk_det_stats, 17, 1) = substr (det_stats, 25, 1);
	substr (temp_dsk_det_stats, 18, 1) = substr (det_stats, 29, 1);
	substr (temp_dsk_det_stats, 19, 4) = substr (det_stats, 33, 4);
	substr (temp_dsk_det_stats, 23, 1) = substr (det_stats, 40, 1);
	substr (temp_dsk_det_stats, 24, 2) = substr (det_stats, 55, 2);


	do i = 1 to 25;
	     if substr (temp_dsk_det_stats, i, 1) then do;
		anlzd = anlzd + 1;
		a_disk_analysis.analyses (anlzd) = trans_table_dsu5xx (i);
		a_is_interesting = "1"b;
		end;
	end;

	go to fill_dsk_struct;


fill_dsk_struct:
	number_analyzed = anlzd;


	if (^rs_sw & ^rsnnl_sw) then do;
	     call hcs_$make_seg ("", "analyze_detail_stat_.temp", "", 10, disk_analp, xcode);
	     auto_analp = disk_analp;
	     disk_analysis.disk_analysis_version = analyze_det_stat_info_version_2;
	     disk_analysis.num_analyzed = anlzd;
	     disk_analysis.dsk_model = a_disk_analysis.dsk_model;
	     disk_analysis.is_interesting_disk = a_is_interesting;
	     disk_analysis.fips_controller = fips_controller;
	     disk_analysis.pad = ""b;
	     disk_analysis.CA = a_disk_analysis.CA;
	     disk_analysis.PORT = a_disk_analysis.PORT;


	     if number_analyzed > 0
	     then do j = 1 to number_analyzed;
		disk_analysis.analyses (j) = a_disk_analysis.analyses (j);
	     end;

	     else disk_analysis.analyses (*) = "";

	     return;
	     end;

	if (rsnnl_sw | rs_sw) then do;
	     if fips_controller
	     then ret_str = "";
	     else call ioa_$rsnnl ("[CA ^1o, Port ^2d]", ret_str, 15, a_disk_analysis.CA, a_disk_analysis.PORT);
	     do j = 1 to number_analyzed;
		message = message || a_disk_analysis.analyses (j);
	     end;
	     message = message || ret_str;
	     if message ^= "" then do;
		if rs_sw then message = message || NEW_LINE;
		is_interesting = a_is_interesting;
		end;
	     else is_interesting = "0"b;
	     end;
	return;
%page;
anal_fips_disk_:
	proc;

dcl  (format_type, message_no) fixed bin;
dcl  symptom_code bit (16);
dcl  trans_tbl (16) char (50) varying int static options (constant) init
						/* misc compacted bits */
	("Command Reject ", "Intervention Required ", "Bus Out Parity Error ", "Equipment Check ", "Data Check ",
	"Overrun ", "Permanent Error ", "Invalid Track Format ", "End of Cylinder ", "No Record Found ",
	"File Protected ", "Write Inhibited ", "Correctable Error ", "Intent Violation ", "Imprecise Ending ",
	"Write Op ");

dcl  format_0_type1_tbl (0:15) char (50) varying int static options (constant) init
						/* program or system checks (byte1,bit3=0) */
	("", "Invalid Command ", "Invalid Command Seq. ", "CCW Count Error ", "Invalid Data Arg ",
	"Diagnostic Command Error ", "Retry status w/o chaining ", "Command Mis-match after Retry ", "", "", "",
	"Def/Alt Track pointing at self ", "Path Select/Device installation Check ", "", "", "");

dcl  format_0_type2_tbl (0:15) char (50) varying int static options (constant) init
						/* program or system checks (byte1,bit3=1) */
	("", "Sense Data Logged for Device ", "Sense Data Logged for Controller ", (13) (""));

dcl  format_1_tbl (0:15) char (50) varying int static options (constant) init
						/* device equipment check */
	("", "Device status 1 was not as expected ", "", "Index was missing ", "Unresettable Interrupt ",
	"Device did not respond to Selection ", "Drive check 2 or Set Sector Incomplete ", "Head Address Miscompare ",
	"Invalid Device Status 1 ", "Device Not Ready ", "Track Physical Address Miscompare ", "",
	"Drive Motor Switch was OFF ", "Seek Incomplete ", "Cylinder Adress Miscompare ", "Unresettable Offset Active ")
	;

dcl  format_2_tbl (0:15) char (50) varying int static options (constant) init
						/* storage director equipment check */
	((9) (""), "Selective Reset while Drive Selected ", "Failed to Latch the First Sync In Line ", "",
	"No Channel Response on a Selective Reset Request ", "", "", "Microcode Detected Error ");

dcl  format_3_tbl (0:15) char (50) varying int static options (constant) init
						/* storage director control check */
	((8) (""), "Clock Stopped Check 1 ", "Channel Check 1 or Storage Director Timeout ",
	"Trace Table saved in this Storage Director ", "", "", "", "", "");

dcl  format_4_tbl (0:15) char (50) varying int static options (constant) init
						/* data check w/o displacement info */
	("Uncorrectable Error in Home Addr ", "Uncorrectable Error in Count Area ", "Uncorrectable Error in Key Area ",
	"Uncorrectable Error in Data Area ", "Unsuccessful Sync on Home Addr ", "Unsuccessful Sync on Count Area ",
	"Unsuccessful Sync on Key Area ", "Unsuccessful Sync on Data Area ",
	"Uncorrectable Error in Home Addr(offset active) ", "Uncorrectable Error in Count Area(offset active) ",
	"Uncorrectable Error in Key Area(offset active) ", "Uncorrectable Error in Data Area(offset active) ",
	"Unsuccessful Sync on Home Addr(offset active) ", "Unsuccessful Sync on Count Area(offset active) ",
	"Unsuccessful Sync on Key Area(offset active) ", "Unsuccessful Sync on Data Area(offset active) ");

dcl  format_5_tbl (0:15) char (50) varying int static options (constant) init
						/* data check with displacement info */
	("Correctable Error in Home Address ", "Correctable Error in Count Area ", "Correctable Error in Key Area ",
	"Correctable Error in Data Area ", (4) (""), "Correctable Error in Home Address(offset active) ",
	"Correctable Error in Count Area(offset active) ", "Correctable Error in Key Area(offset active) ",
	"Correctable Error in Data Area(offset active) ", (4) (""));

dcl  format_6_tbl (0:15) char (50) varying int static options (constant) init
						/* usage statistics/overrun errors */
	((8) (""), "Channel A overrun ", "Channel B overrun ", "Channel C overrun ", "Channel D overrun ",
	"Channel E overrun ", "Channel F overrun ", "Channel G overrun ", "Channel H overrun ");

dcl  format_7_tbl (0:15) char (50) varying int static options (constant) init
						/* SD-to-controller path or controller check */
	("RCC Initiated by a CCA ", "Unsuccessful RCC1 sequence ", "Unsuccessful RCC1 and RCC2 sequence ",
	"Invalid DDC Tag Sequence ", "Extra RCC Required ", "Invalid DDC selection Response or Timeout ",
	"Missing End Op Transfer was Complete ", "Missing End Op Transfer was Incomplete ",
	"Invalid Tag In on Immediate Command ", "Invalid Tag In for Extended Command Sequence ", "Deselection Timeout ",
	"No Controller Response after Poll Interrupt ", "Controller Not Available ",
	"Controller Not Available on Disconnected Chain ", "", "");

dcl  format_8_tbl (0:15) char (50) varying int static options (constant) init
						/* Controller Equipment check */
	("", "ECC Hardware Failure ", "", "Unexpected End Op Response code Received ",
	"End Op Active with Transfer Count > 0 ", "End Op Active with Transfer Count = 0 ",
	"Controller Stopped The Path Selection Cleanup ", "DPS array conot be Initialized ",
	"Short Busy timeout during Device Selection ", "Controller failed to set/reset long-term Busy ", (6) (""));

	     if dev_model = 3380
	     then a_disk_analysis.dsk_model = "IBM3380";
	     else a_disk_analysis.dsk_model = "IBM3390";
	     a_disk_analysis.CA, a_disk_analysis.PORT = 0;
	     substr (temp_dsk_det_stats, 1, 6) = substr (det_stats, 1, 6);
	     substr (temp_dsk_det_stats, 7, 3) = substr (det_stats, 9, 3);
	     substr (temp_dsk_det_stats, 10, 3) = substr (det_stats, 13, 3);
	     substr (temp_dsk_det_stats, 13, 1) = substr (det_stats, 18, 1);
	     substr (temp_dsk_det_stats, 14, 3) = substr (det_stats, 21, 3);

	     do i = 1 to 16;
		if substr (temp_dsk_det_stats, i, 1) then do;
		     anlzd = anlzd + 1;
		     a_disk_analysis.analyses (anlzd) = trans_tbl (i);
		     a_is_interesting = "1"b;
		     end;
	     end;

	     anlzd = anlzd + 1;
	     a_disk_analysis.analyses (anlzd) = "";
	     a_is_interesting = "1"b;
	     format_type = bin (substr (det_stats, 57, 4), 4);
	     message_no = bin (substr (det_stats, 61, 4), 4);

	     if format_type = 0 then do;
		if ^substr (det_stats, 12, 1)
		then a_disk_analysis.analyses (anlzd) = format_0_type1_tbl (message_no);
		else a_disk_analysis.analyses (anlzd) = format_0_type2_tbl (message_no);
		end;
	     else if format_type = 1 then a_disk_analysis.analyses (anlzd) = format_1_tbl (message_no);
	     else if format_type = 2 then a_disk_analysis.analyses (anlzd) = format_2_tbl (message_no);
	     else if format_type = 3 then a_disk_analysis.analyses (anlzd) = format_3_tbl (message_no);
	     else if format_type = 4 then a_disk_analysis.analyses (anlzd) = format_4_tbl (message_no);
	     else if format_type = 5 then a_disk_analysis.analyses (anlzd) = format_5_tbl (message_no);
	     else if format_type = 6 then a_disk_analysis.analyses (anlzd) = format_6_tbl (message_no);
	     else if format_type = 7 then a_disk_analysis.analyses (anlzd) = format_7_tbl (message_no);
	     else if format_type = 8 then a_disk_analysis.analyses (anlzd) = format_8_tbl (message_no);

	     if a_disk_analysis.analyses (anlzd) = "" then do;
						/* no message */
		anlzd = anlzd - 1;
		if anlzd = 0 then a_is_interesting = "0"b;
						/* nothing interesting */
		end;

	     if a_is_interesting & (format_type ^= 5 & format_type ^= 6) then do;
		symptom_code = substr (det_stats, 177, 16);
						/* bytes 22 & 23 */
		if symptom_code ^= ""b then do;
		     anlzd = anlzd + 1;
		     call ioa_$rsnnl ("Symptom_code=^4.4b ", a_disk_analysis.analyses (anlzd), 18, symptom_code);
		     end;
		end;
	     return;
	end anal_fips_disk_;
     end anal_disk_;

%page;


anal_prt_:
     proc;

dcl  ptr_model fixed bin;
dcl  DENSITY (2) char (6) int static options (constant) init ("6 lpi.", "8 lpi.");
dcl  temp_prt_det_stat bit (44) init ("0"b);
dcl  (msg_indx, bysc) fixed bin;
dcl  ec_sc_bit bit (10) init ("0"b);
dcl  pr71_index fixed bin;


dcl  trans_table_prt (40) char (36) var int static options (constant) init
						/* for pr71 */
	("Print Check. ", "Belt Sync Error. ", "Scanning register Error. ", "LNS Delay Error. ",
	"DAI Data Parity Error. ", "Bad PLB Address Increment. ", "PLB Parity Error. ",
	"Non-printable Character in PLB. ", "Fire Hammer Register Error. ", "Invalid PLB Address. ",
	"Image Belt Buffer Parity Error. ", "Image Belt Address Error. ", "Invalid Image Belt Buffer Address. ",
	"Space Line Error. ", "Sync Error. ", "Tractors Not Engaged. ", "Belt gate Open. ", "Broken Finger on Belt. ",
	"Vertical Belt Position. ", "Ribbon Error. ", "Skew Error. ", "Stacker Error. ", "Phase Failure Alert. ",
	"DC Alert. ", "Thermal Alert. ", "Skip Supply Alert. ", "Print Supply Alert. ", "Paper Failure. ",
	"Paper Runaway. ", "Emergency Off. ", "Skip Overcurrent. ", "Finger Sensor Failure. ", "Finger Sensor Dirty. ",
	"Airflow Check. ", "AC Overcurrent. ", "Multiple Echo Check Error. ", "Echo Check Error. ",
	"Short Circuit Error No. 2. ", "Short Circuit Error No. 1. ", "Short Circuit Error No. 1 and 2. ");


dcl  col_trans_136 (1:9, 0:15) char (35) var int static options (constant) init
						/* for pr71 */
	("Bad Decode. ", "Col. 04, Hammer Driver Card 04. ", "Bad Decode. ", "Bad Decode. ",
	"Col. 05, Hammer Driver Card 04. ", "Bad Decode. ", "Bad Decode. ", "Col. 06, Hammer Driver Card 04. ",
	"Col. 01, Hammer Driver Card 04. ", "Bad Decode. ", "Col. 07, Hammer Driver Card 04. ",
	"Col. 02, Hammer Driver Card 04. ", "Bad Decode. ", "Col. 08, Hammer Driver Card 04. ",
	"Col. 03, Hammer Driver Card 04. ", "Bad Decode. ", "Col. 09, Hammer Driver Card 05. ",
	"Col. 20, Hammer Driver Card 06. ", "Col. 15, Hammer Driver Card 05. ", "Col. 10, Hammer Driver Card 05. ",
	"Col. 21, Hammer Driver Card 06. ", "Col. 16, Hammer Driver Card 05. ", "Col. 11, Hammer Driver Card 05. ",
	"Col. 22, Hammer Driver Card 06. ", "Col. 17, Hammer Driver Card 06. ", "Col. 12, Hammer Driver Card 05. ",
	"Col. 23, Hammer Driver Card 06. ", "Col. 18, Hammer Driver Card 06. ", "Col. 13, Hammer Driver Card 05. ",
	"Col. 24, Hammer Driver Card 06. ", "Col. 19, Hammer Driver Card 06. ", "Col. 14, Hammer Driver Card 05. ",
	"Col. 25, Hammer Driver Card 07. ", "Col. 36, Hammer Driver Card 08. ", "Col. 31, Hammer Driver Card 07. ",
	"Col. 26, Hammer Driver Card 07. ", "Col. 37, Hammer Driver Card 08. ", "Col. 32, Hammer Driver Card 07. ",
	"Col. 27, Hammer Driver Card 07. ", "Col. 38, Hammer Driver Card 08. ", "Col. 33, Hammer Driver Card 08. ",
	"Col. 28, Hammer Driver Card 07. ", "Col. 39, Hammer Driver Card 08. ", "Col. 34, Hammer Driver Card 08. ",
	"Col. 29, Hammer Driver Card 07. ", "Col. 40, Hammer Driver Card 08. ", "Col. 35, Hammer Driver Card 08. ",
	"Col. 30, Hammer Driver Card 07. ", "Col. 41, Hammer Driver Card 09. ", "Col. 52, Hammer Driver Card 10. ",
	"Col. 47, Hammer Driver Card 09. ", "Col. 42, Hammer Driver Card 09. ", "Col. 53, Hammer Driver Card 10. ",
	"Col. 48, Hammer Driver Card 09. ", "Col. 43, Hammer Driver Card 09. ", "Col. 54, Hammer Driver Card 10. ",
	"Col. 49, Hammer Driver Card 10. ", "Col. 44, Hammer Driver Card 09. ", "Col. 55, Hammer Driver Card 10. ",
	"Col. 50, Hammer Driver Card 10. ", "Col. 45, Hammer Driver Card 09. ", "Col. 56, Hammer Driver Card 10. ",
	"Col. 51, Hammer Driver Card 10. ", "Col. 46, Hammer Driver Card 09. ", "Col. 57, Hammer Driver Card 11. ",
	"Col. 68, Hammer Driver Card 12. ", "Col. 63, Hammer Driver Card 11. ", "Col. 58, Hammer Driver Card 11. ",
	"Col. 69, Hammer Driver Card 12. ", "Col. 64, Hammer Driver Card 11. ", "Col. 59, Hammer Driver Card 11. ",
	"Col. 70, Hammer Driver Card 12. ", "Col. 65, Hammer Driver Card 12. ", "Col. 60, Hammer Driver Card 11. ",
	"Col. 71, Hammer Driver Card 12. ", "Col. 66, Hammer Driver Card 12. ", "Col. 61, Hammer Driver Card 11. ",
	"Col. 72, Hammer Driver Card 12. ", "Col. 67, Hammer Driver Card 12. ", "Col. 62, Hammer Driver Card 11. ",
	"Col. 73, Hammer Driver Card 13. ", "Col. 84, Hammer Driver Card 14. ", "Col. 79, Hammer Driver Card 13. ",
	"Col. 74, Hammer Driver Card 13. ", "Col. 85, Hammer Driver Card 14. ", "Col. 80, Hammer Driver Card 13. ",
	"Col. 75, Hammer Driver Card 13. ", "Col. 86, Hammer Driver Card 14. ", "Col. 81, Hammer Driver Card 14. ",
	"Col. 76, Hammer Driver Card 13. ", "Col. 87, Hammer Driver Card 14. ", "Col. 82, Hammer Driver Card 14. ",
	"Col. 77, Hammer Driver Card 13. ", "Col. 88, Hammer Driver Card 14. ", "Col. 83, Hammer Driver Card 14. ",
	"Col. 78, Hammer Driver Card 13. ", "Col. 89, Hammer Driver Card 15. ", "Col. 100, Hammer Driver Card 16. ",
	"Col. 95, Hammer Driver Card 15. ", "Col. 90, Hammer Driver Card 15. ", "Col. 101, Hammer Driver Card 16. ",
	"Col. 96, Hammer Driver Card 15. ", "Col. 91, Hammer Driver Card 15. ", "Col. 102, Hammer Driver Card 16. ",
	"Col. 97, Hammer Driver Card 16. ", "Col. 92, Hammer Driver Card 15. ", "Col. 103, Hammer Driver Card 16. ",
	"Col. 98, Hammer Driver Card 16. ", "Col. 93, Hammer Driver Card 15. ", "Col. 104, Hammer Driver Card 16. ",
	"Col. 99, Hammer Driver Card 16. ", "Col. 94, Hammer Driver Card 15. ", "Col. 105, Hammer Driver Card 17. ",
	"Col. 116, Hammer Driver Card 18. ", "Col. 111, Hammer Driver Card 17. ", "Col. 106, Hammer Driver Card 17. ",
	"Col. 117, Hammer Driver Card 18. ", "Col. 112, Hammer Driver Card 17. ", "Col. 107, Hammer Driver Card 17. ",
	"Col. 118, Hammer Driver Card 18. ", "Col. 113, Hammer Driver Card 18. ", "Col. 108, Hammer Driver Card 17. ",
	"Col. 119, Hammer Driver Card 18. ", "Col. 114, Hammer Driver Card 18. ", "Col. 109, Hammer Driver Card 17. ",
	"Col. 120, Hammer Driver Card 18. ", "Col. 115, Hammer Driver Card 18. ", "Col. 110, Hammer Driver Card 17. ",
	"Col. 121, Hammer Driver Card 19. ", "Col. 132, Hammer Driver Card 20. ", "Col. 127, Hammer Driver Card 19. ",
	"Col. 122, Hammer Driver Card 19. ", "Col. 133, Hammer Driver Card 20. ", "Col. 128, Hammer Driver Card 19. ",
	"Col. 123, Hammer Driver Card 19. ", "Col. 134, Hammer Driver Card 20. ", "Col. 129, Hammer Driver Card 20. ",
	"Col. 124, Hammer Driver Card 19. ", "Col. 135, Hammer Driver Card 20. ", "Col. 130, Hammer Driver Card 20. ",
	"Col. 125, Hammer Driver Card 19. ", "Col. 136, Hammer Driver Card 20. ", "Col. 131, Hammer Driver Card 20. ",
	"Col. 126, Hammer Driver Card 19. ");

dcl  col_trans_160 (0:9, 0:15) char (35) var int static options (constant) init
						/* for pr71 */
	("Col. 1, Hammer Driver Card 1. ", "Col. 12, Hammer Driver Card 2. ", "Col. 7, Hammer Driver Card 1. ",
	"Col. 2, Hammer Driver Card 1. ", "Col. 13, Hammer Driver Card 2. ", "Col. 8, Hammer Driver Card 1. ",
	"Col. 3, Hammer Driver Card 1. ", "Col. 14, Hammer Driver Card 2. ", "Col. 9, Hammer Driver Card 2. ",
	"Col. 4, Hammer Driver Card 1. ", "Col. 15, Hammer Driver Card 2. ", "Col. 10, Hammer Driver Card 2. ",
	"Col. 5, Hammer Driver Card 1. ", "Col. 16, Hammer Driver Card 2. ", "Col. 11, Hammer Driver Card 2. ",
	"Col. 6, Hammer Driver Card 1. ", "Col. 17, Hammer Driver Card 3. ", "Col. 28, Hammer Driver Card 4. ",
	"Col. 23, Hammer Driver Card 3. ", "Col. 18, Hammer Driver Card 3. ", "Col. 29, Hammer Driver Card 4. ",
	"Col. 24, Hammer Driver Card 3. ", "Col. 19, Hammer Driver Card 3. ", "Col. 30, Hammer Driver Card 4. ",
	"Col. 25, Hammer Driver Card 4. ", "Col. 20, Hammer Driver Card 3. ", "Col. 31, Hammer Driver Card 4. ",
	"Col. 26, Hammer Driver Card 4. ", "Col. 21, Hammer Driver Card 3. ", "Col. 32, Hammer Driver Card 4. ",
	"Col. 27, Hammer Driver Card 4. ", "Col. 22, Hammer Driver Card 3. ", "Col. 33, Hammer Driver Card 5. ",
	"Col. 44, Hammer Driver Card 6. ", "Col. 39, Hammer Driver Card 5. ", "Col. 34, Hammer Driver Card 5. ",
	"Col. 45, Hammer Driver Card 6. ", "Col. 40, Hammer Driver Card 5. ", "Col. 35, Hammer Driver Card 5. ",
	"Col. 46, Hammer Driver Card 6. ", "Col. 41, Hammer Driver Card 6. ", "Col. 36, Hammer Driver Card 5. ",
	"Col. 47, Hammer Driver Card 6. ", "Col. 42, Hammer Driver Card 6. ", "Col. 37, Hammer Driver Card 5. ",
	"Col. 48, Hammer Driver Card 6. ", "Col. 43, Hammer Driver Card 6. ", "Col. 38, Hammer Driver Card 5. ",
	"Col. 49, Hammer Driver Card 7. ", "Col. 60, Hammer Driver Card 8. ", "Col. 55, Hammer Driver Card 7. ",
	"Col. 50, Hammer Driver Card 7. ", "Col. 61, Hammer Driver Card 8. ", "Col. 56, Hammer Driver Card 7. ",
	"Col. 51, Hammer Driver Card 7. ", "Col. 62, Hammer Driver Card 8. ", "Col. 57, Hammer Driver Card 8. ",
	"Col. 52, Hammer Driver Card 7. ", "Col. 63, Hammer Driver Card 8. ", "Col. 58, Hammer Driver Card 8. ",
	"Col. 53, Hammer Driver Card 7. ", "Col. 64, Hammer Driver Card 8. ", "Col. 59, Hammer Driver Card 8. ",
	"Col. 54, Hammer Driver Card 7. ", "Col. 65, Hammer Driver Card 9. ", "Col. 76, Hammer Driver Card 10. ",
	"Col. 71, Hammer Driver Card 9. ", "Col. 66, Hammer Driver Card 9. ", "Col. 77, Hammer Driver Card 10. ",
	"Col. 72, Hammer Driver Card 9. ", "Col. 67, Hammer Driver Card 9. ", "Col. 78, Hammer Driver Card 10. ",
	"Col. 73, Hammer Driver Card 10. ", "Col. 68, Hammer Driver Card 9. ", "Col. 79, Hammer Driver Card 10. ",
	"Col. 74, Hammer Driver Card 10. ", "Col. 69, Hammer Driver Card 9. ", "Col. 80, Hammer Driver Card 10. ",
	"Col. 75, Hammer Driver Card 10. ", "Col. 70, Hammer Driver Card 9. ", "Col. 81, Hammer Driver Card 11. ",
	"Col. 92, Hammer Driver Card 12. ", "Col. 87, Hammer Driver Card 11. ", "Col. 82, Hammer Driver Card 11. ",
	"Col. 93, Hammer Driver Card 12. ", "Col. 88, Hammer Driver Card 11. ", "Col. 83, Hammer Driver Card 11. ",
	"Col. 94, Hammer Driver Card 12. ", "Col. 89, Hammer Driver Card 12. ", "Col. 84, Hammer Driver Card 11. ",
	"Col. 95, Hammer Driver Card 12. ", "Col. 90, Hammer Driver Card 12. ", "Col. 85, Hammer Driver Card 11. ",
	"Col. 96, Hammer Driver Card 12. ", "Col. 91, Hammer Driver Card 12. ", "Col. 86, Hammer Driver Card 11. ",
	"Col. 97, Hammer Driver Card 13. ", "Col. 108, Hammer Driver Card 14. ", "Col. 103, Hammer Driver Card 13. ",
	"Col. 98, Hammer Driver Card 13. ", "Col. 109, Hammer Driver Card 14. ", "Col. 104, Hammer Driver Card 13. ",
	"Col. 99, Hammer Driver Card 13. ", "Col. 110, Hammer Driver Card 14. ", "Col. 105, Hammer Driver Card 14. ",
	"Col. 100, Hammer Driver Card 13. ", "Col. 111, Hammer Driver Card 14. ", "Col. 106, Hammer Driver Card 14. ",
	"Col. 101, Hammer Driver Card 13. ", "Col. 112, Hammer Driver Card 14. ", "Col. 107, Hammer Driver Card 14. ",
	"Col. 102, Hammer Driver Card 13. ", "Col. 113, Hammer Driver Card 15. ", "Col. 124, Hammer Driver Card 16. ",
	"Col. 119, Hammer Driver Card 15. ", "Col. 114, Hammer Driver Card 15. ", "Col. 125, Hammer Driver Card 16. ",
	"Col. 120, Hammer Driver Card 15. ", "Col. 115, Hammer Driver Card 15. ", "Col. 126, Hammer Driver Card 16. ",
	"Col. 121, Hammer Driver Card 16. ", "Col. 116, Hammer Driver Card 15. ", "Col. 127, Hammer Driver Card 16. ",
	"Col. 122, Hammer Driver Card 16. ", "Col. 117, Hammer Driver Card 15. ", "Col. 128, Hammer Driver Card 16. ",
	"Col. 123, Hammer Driver Card 16. ", "Col. 118, Hammer Driver Card 15. ", "Col. 129, Hammer Driver Card 17. ",
	"Col. 140, Hammer Driver Card 18. ", "Col. 135, Hammer Driver Card 17. ", "Col. 130, Hammer Driver Card 17. ",
	"Col. 141, Hammer Driver Card 18. ", "Col. 136, Hammer Driver Card 17. ", "Col. 131, Hammer Driver Card 17. ",
	"Col. 142, Hammer Driver Card 18. ", "Col. 137, Hammer Driver Card 18. ", "Col. 132, Hammer Driver Card 17. ",
	"Col. 143, Hammer Driver Card 18. ", "Col. 138, Hammer Driver Card 18. ", "Col. 133, Hammer Driver Card 17. ",
	"Col. 144, Hammer Driver Card 18. ", "Col. 139, Hammer Driver Card 18. ", "Col. 134, Hammer Driver Card 17. ",
	"Col. 145, Hammer Driver Card 19. ", "Col. 156, Hammer Driver Card 20. ", "Col. 151, Hammer Driver Card 19. ",
	"Col. 146, Hammer Driver Card 19. ", "Col. 157, Hammer Driver Card 20. ", "Col. 152, Hammer Driver Card 19. ",
	"Col. 147, Hammer Driver Card 19. ", "Col. 158, Hammer Driver Card 20. ", "Col. 153, Hammer Driver Card 20. ",
	"Col. 148, Hammer Driver Card 19. ", "Col. 159, Hammer Driver Card 20. ", "Col. 154, Hammer Driver Card 20. ",
	"Col. 149, Hammer Driver Card 19. ", "Col. 160, Hammer Driver Card 20. ", "Col. 155, Hammer Driver Card 20. ",
	"Col. 150, Hammer Driver Card 19. ");

dcl  pr54_byte12 (7:99) char (60) var int static options (constant)
	init ("Manual Halt, PRT Off-Line. ", "EOP or EOS out of Sequence. ", "",
						/* ignore paper low */
	"Invalid VFC Load. ", "PRT Off-Line. ", "Paper Motion Alert, No VFC Channel Match. ",
	"BIB From System Does Not Contain 240 Chars. ", "Invalid Line Density In VFC Load. ",
	"Form Length Greater Than 144 line in VFC Load. ", "Invalid Line No. In VFC Load. ",
	"Invalid Auto Slew Data in VFC Load. ", "Invalid TOP/BOP in VFC Load. ", "Error on Status Read. ",
	"Unexpected PDSI Reg. in Response Frame. ", "TTE, No Response From PRT. ", "Horizontal Tab Greater Than 127. ",
	"Left Tab Operation Attempted. ", "Vertical Tab Greater Than 127. ", "Horizontal Skip Greater Than 127. ",
	"Skip Past End of Line. ", "ASCII CTL CHAR in Non-Edit Mode. ", "Invalid Code (1C). ",
						/* 1c thru 2d undefined */
	"Invalid Code (1D). ",			/* Define them as invalid */
	"Invalid Code (1E). ",			/* as it will indicate a HW problem */
	"Invalid Code (1F). ",			/* if they are entered */
	"Invalid Code (20). ", "Invalid Code (21). ", "Invalid Code (22). ", "Invalid Code (23). ",
	"Invalid Code (24). ", "Invalid Code (25). ", "Invalid Code (26). ", "Invalid Code (27). ",
	"Invalid Code (28). ", "Invalid Code (29). ", "Invalid Code (2A). ", "Invalid Code (2B). ",
	"Invalid Code (2C). ", "Invalid Code (2D). ", "Power OFF, No Response on Link. ", "Link Error, EURC ALERT. ",
	"Link Error, EURC Attention. ", "ATTN Cond. On Previous Operation. ", "", "Skip Loop CTL Error [FC=01]. ",
	"Invalid Code (34). ", "Tractors De-clutched [FC=03]. ", "Paper Jam at Tractors [FC=04]. ", "",
						/* paper low, ignore */
	"Yoke Open [FC=06]. ", "Broken Finger [FC=07]. ", "Belt Start Problem [FC=08]. ",
	"Ribbon Motion Problem [FC=09]. ", "Ribbon Seam Time-out [FC=0A]. ", "Stacker Alert [FC=0B]. ",
	"Ribbon Cartridge Not Present [FC=0C]. ", "Invalid Code (3F). ", "Line Strobe Problem [FC=0E]. ",
	"Invalid Code (41). ", "Invalid Code (42). ", "Invalid Code (43). ", "Invalid Code (44). ",
	"Invalid Code (45). ", "Character Not on Band Image [FC=14]. ", "Invalid Code (47). ", "Invalid Code (48). ",
	"Invalid Code (49). ", "Invalid Code (4A). ", "Echo Check IMP1 PWA [FC=19]. ", "Echo Check IMP2 PWA [FC=1A]. ",
	"Over Temperature [FC=1B]. ", "Skip PWA Failure [FC=1C]. ", "+40V failure [FC=1D]. ", "-40V Failure [FC=1E]. ",
	"Belt Command Failure [FC=1F]. ", "-9V Failure [FC=20]. ", "Dialogue Failure MPI to INT PWA [FC=21]. ",
	"Print/Slew Time-out. ", "Invalid Code (55). ", "Invalid Code (56). ", "Invalid Code (57). ",
	"Invalid Code (58). ", "Invalid Code (59). ", "Invalid Code (5A). ", "PLB Load Overflow [FC=91]. ",
	"VFU Load Overflow [FC=92]. ", "BIB Load Overflow [FC=93]. ", "Invalid BIB Data Load [FC=94]. ",
	"Invalid VFU Data Load [FC=95]. ", "Invalid VFU Channel No. [FC=96]. ",
	"No Stop on Selected VFU Channel [FC=97]. ", "Invalid Command Sequence [FC=98]. ",
	"Illegal Command Code [FC=99]. ");
%page;

	a_prt_analysis.prt_model = "";
	a_prt_analysis.density = "";
	a_prt_analysis.analyses (*) = "";
	anlzd = 0;
	statp = addr (iom_stats);



/* Check iom status to see if detail status is worth analyzing */


	if stat_maj = "0010"b then ;			/* dev attn */


	else if stat_maj = "0011"b then ;		/* any dev data alert */
	else if (stat_maj = "0101"b) &		/* cmd rej */
	     (fixed (stat_min, 6) = 20 |		/* slew error */
	     fixed (stat_min, 6) = 40)
	then ;					/* TOP echo */

	else if stat_maj = "1010"b then ;		/* mpc attn */


	else if stat_maj = "1011"b then ;		/* mpc data alert */


	else do;

/* detail status is either not available or not worthy of analysis, return */


	     anlzd = 0;
	     code = error_table_$request_not_recognized;
	     return;
	     end;

/*  Scan the config deck to determine the type of prt we are working on  */

	prph_cardp = null ();
	call config_$find_periph (substr (name, 1, 4), prph_cardp);
	if prph_cardp = null () then do;
	     code = error_table_$resource_unknown;
	     return;
	     end;
	ptr_model = prph_card.model;

	if ptr_model = 1200 | ptr_model = 1600
	then					/* PR71 */
	     go to do_PR71;

	if ptr_model = 901 | ptr_model = 1000 | ptr_model = 1201
	then					/* PR54 */
	     go to do_PR54;

	go to unimplemented;			/* don't know this type */
%page;

/* Routine for PR71 */

do_PR71:
	if substr (det_stats, 48, 1) then goto do_PR54;	/* only PR54s have this bit on! */
	pr71_index = 1;
	a_prt_analysis.prt_model = "PRU" || ltrim (char (ptr_model));

	if fixed (substr (det_stats, 23, 2), 2) ^= 0	/* 1=6lpi, 2=8lpi */
	then if fixed (substr (det_stats, 23, 2), 2) < 3
	     then a_prt_analysis.density = DENSITY (fixed (substr (det_stats, 23, 2), 2));

	if (stat_maj = "0010"b) & (stat_min = "0"b) then do;
						/* if power fault */
	     pr71_index = 23;
	     go to check_pr71_fault;
	     end;

	if substr (det_stats, 1, 1) ^= "1"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "Belt Image Not Loaded. ";
	     a_is_interesting = "1"b;
	     end;

	if substr (det_stats, 25, 1) ^= "1"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "VFC Image Not Loaded. ";
	     a_is_interesting = "1"b;
	     end;

	if substr (det_stats, 26, 1) ^= "1"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "VFC Out of Sync. ";
	     a_is_interesting = "1"b;
	     end;

check_pr71_fault:
	substr (temp_prt_det_stat, 1, 1) = substr (det_stats, 35, 1);
	substr (temp_prt_det_stat, 2, 4) = substr (det_stats, 43, 4);
	substr (temp_prt_det_stat, 6, 11) = substr (det_stats, 49, 11);
	substr (temp_prt_det_stat, 17, 6) = substr (det_stats, 65, 6);
	substr (temp_prt_det_stat, 23, 8) = substr (det_stats, 73, 8);
	substr (temp_prt_det_stat, 31, 5) = substr (det_stats, 83, 5);
	substr (temp_prt_det_stat, 36, 2) = substr (det_stats, 41, 2);
	substr (temp_prt_det_stat, 38, 2) = substr (det_stats, 81, 2);

	do i = pr71_index to 35;
	     if substr (temp_prt_det_stat, i, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_prt_analysis.analyses (anlzd) = trans_table_prt (i);
		a_is_interesting = "1"b;
		end;
	end;


/* Now check for echo check and short circuit errors */

	if fixed (substr (det_stats, 41, 2), 2) > 0 then do;
						/* echo ck err */
	     msg_indx = fixed (substr (det_stats, 41, 2), 2);

	     if msg_indx > 2 then msg_indx = 1;

	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = trans_table_prt (35 + msg_indx);
	     bysc = fixed (substr (det_stats, 101, 4), 4);/* use for col decode */
	     ec_sc_bit = substr (det_stats, 89, 10);
	     go to anal_ec_sc;
	     end;

	else if fixed (substr (det_stats, 81, 2), 2) > 0 then do;
						/* short ckt err */

	     msg_indx = fixed (substr (det_stats, 81, 2), 2);
	     if msg_indx > 2 then msg_indx = 3;

	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = trans_table_prt (37 + msg_indx);
	     bysc = fixed (substr (det_stats, 117, 4), 4);/* use for col decode */
	     ec_sc_bit = substr (det_stats, 105, 10);
	     go to anal_ec_sc;
	     end;

	else go to fill_prt_struct;
anal_ec_sc:
	if substr (det_stats, 17, 3) = "001"b
	then					/* 136 col prt */
	     do i = 1 to 10;
	     if substr (ec_sc_bit, i, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_prt_analysis.analyses (anlzd) = col_trans_136 (i - 1, bysc);
		a_is_interesting = "1"b;
		end;
	end;

	else if substr (det_stats, 17, 3) = "010"b
	then					/* 160 col prt */
	     do i = 1 to 10;
	     if substr (ec_sc_bit, i, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_prt_analysis.analyses (anlzd) = col_trans_160 (i - 1, bysc);
		a_is_interesting = "1"b;
		end;
	end;


	else do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "Cannot Determine Number of Columns.";
	     end;

	go to fill_prt_struct;

%page;

/* Routine for PR54 */

do_PR54:
	a_prt_analysis.prt_model = "PRU" || ltrim (char (ptr_model));
	if substr (det_stats, 121, 1) = "0"b		/* 0=6lpi, 1=8lpi */
	then a_prt_analysis.density = DENSITY (1);
	else a_prt_analysis.density = DENSITY (2);

	if substr (det_stats, 1, 1) = "0"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "Belt Image Not Loaded. ";
	     a_is_interesting = "1"b;
	     end;

	if substr (det_stats, 25, 1) = "0"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "VFC Image Not Loaded. ";
	     a_is_interesting = "1"b;
	     end;

	if substr (det_stats, 26, 1) = "0"b then do;
	     anlzd = anlzd + 1;
	     a_prt_analysis.analyses (anlzd) = "VFC Out of Sync. ";
	     a_is_interesting = "1"b;
	     end;


	if substr (det_stats, 97, 8) ^= "0"b then do;	/* bypass paper out */
	     i = bin (substr (det_stats, 97, 8), 8);
	     if i < 7 then goto fill_prt_struct;	/* and CMD REJs */
	     anlzd = anlzd + 1;

	     if i ^> 99
	     then					/* Max table entry of 63hex */
		a_prt_analysis.analyses (anlzd) = pr54_byte12 (i);

	     else a_prt_analysis.analyses (anlzd) = "Illegal Code in Byte 12. ";
	     a_is_interesting = "1"b;
	     end;

	if substr (det_stats, 105, 8) = "ff"b4
	then					/* Not an error */
	     go to fill_prt_struct;			/* no more error bytes */

%page;
fill_prt_struct:
	number_analyzed = anlzd;

	if (^rs_sw & ^rsnnl_sw) then do;
	     call hcs_$make_seg ("", "analyze_detail_stat_.temp", "", 10, prt_analp, xcode);
	     auto_analp = prt_analp;
	     prt_analysis.prt_analysis_version = analyze_det_stat_info_version_1;
	     prt_analysis.num_analyzed = anlzd;
	     prt_analysis.prt_model = a_prt_analysis.prt_model;
	     prt_analysis.density = a_prt_analysis.density;
	     prt_analysis.is_interesting_prt = a_is_interesting;


	     if number_analyzed > 0
	     then do j = 1 to number_analyzed;
		prt_analysis.analyses (j) = a_prt_analysis.analyses (j);
	     end;

	     else prt_analysis.analyses (*) = "";
	     return;
	     end;

	if (rsnnl_sw | rs_sw) then do;
	     do j = 1 to number_analyzed;
		message = message || a_prt_analysis.analyses (j);
	     end;
	     if message ^= "" then do;
		if rs_sw then message = message || NEW_LINE;
		is_interesting = a_is_interesting;
		end;
	     else is_interesting = "0"b;
	     end;

	return;


unimplemented:
	code = error_table_$unimplemented_version;
	return;
     end anal_prt_;

%page;
anal_rdr_pun:
     proc;

dcl  rdr_pun char (3) init ("");
dcl  rdr_pun_model fixed bin;
dcl  rdr_pun_trans_table (50) char (34) var int static options (constant)
	init ("Punch Station Present. ", "Punch Buffer Allow. ", "Jam Between Read & Punch Station. ",
	"Jam on Incremental Failure. ", "Jam on Extra Strobe. ", "Blank Data Found. ", "Punch Error, COL 1 Knives. ",
	"Punch Error, COL 2 Knives. ", "Punch Error, COL 41 Knives. ", "Punch error, COL 42 Knives. ",
	"Disconnect to DOE. ", "Inhibit EV3'S. ", "Set APM1 to DOE. ", "Set APM2 to DOE. ", "Set APM3 to DOE. ",
	"Set APM4 to DOE. ", "Set APM5 to DOE. ", "Lower Light to DOE. ", "Read Compare Error. ",
	"All Light/dark Check. ", "Strobe Count Error. ", "Transfer Error. ", "Illegal Punch. ", "Blank Card. ",
	"Address Incrementing Command. ", "EV1 Present. ", "Hopper Empty. ", "Stacker Full. ", "Anti-Fountain Off. ",
	"Throat Error. ", "JPK/JRK Type Jam. ", "Jam in Kick Station. ", "Chad Box Full. ", "Interlock Open. ",
	"Jam in Wait Station. ", "Jam in Read Station. ", "EV2 Present. ", "End of Process. ", "Device Ready. ",
	"Data Parity Error. ", "Read Lamp Voltage Marginal. ", "+5 volts Low. ", "Punch Lamp Marginal. ",
	"Index Time Marginal. ", "Check Byte Count. ", "Residual Byte Count. ", "Buffer Check Error. ", "Illegal EV1. ",
	"NO End of Process. ", "Device Timer Runout. ");

dcl  board_code (2:7) char (9) int static options (constant)
	init ("RCL PWB. ", "RCL PWB. ", "RCL PWB. ", "PPK PWB. ", "PPK PWB. ", "RSL PWB. ");

dcl  temp_rdr_pun_dtstat bit (72);


	a_rdr_pun_analysis.rdr_pun_model = "";
	a_rdr_pun_analysis.analyses (*) = "";
	anlzd = 0;
	statp = addr (iom_stats);

/*  Now check iom status to see if its worth it */


	if (stat_maj = "0010"b) &			/* attention, but not chad box full */
	     (fixed (stat_min, 6) ^= 4)
	then ;

	else if (stat_maj = "0011"b) then ;		/* any dev data alert */

	else if stat_maj = "1011"b then ;		/* mpc data alert */

	else if stat_maj = "1010"b then ;		/* mpc attention */

	else do;

/* detail status is either not available or not worthy of analysis, return */


	     anlzd = 0;
	     code = error_table_$request_not_recognized;
	     return;
	     end;

/*  Scan the config deck to determine the type of rdr/pun we are working on  */

	prph_cardp = null ();
	call config_$find_periph ((name), prph_cardp);
	if prph_cardp = null () then do;
	     code = error_table_$resource_unknown;
	     return;
	     end;
	rdr_pun_model = prph_card.model;
	if substr (name, 1, 3) = "rdr"
	then rdr_pun = "CRZ";
	else rdr_pun = "CPZ";

	if rdr_pun_model ^= 300
	then if rdr_pun_model ^= 301 then go to not_yet;


	a_rdr_pun_analysis.rdr_pun_model = rdr_pun || ltrim (char (rdr_pun_model));
	substr (temp_rdr_pun_dtstat, 1, 6) = substr (det_stats, 1, 6);
	substr (temp_rdr_pun_dtstat, 7, 4) = substr (det_stats, 9, 4);
	substr (temp_rdr_pun_dtstat, 11, 24) = substr (det_stats, 17, 24);
	substr (temp_rdr_pun_dtstat, 35, 11) = substr (det_stats, 47, 11);
	substr (temp_rdr_pun_dtstat, 46, 5) = substr (det_stats, 65, 5);

	do i = 1 to hbound (rdr_pun_trans_table, 1);
	     if substr (temp_rdr_pun_dtstat, i, 1) then do;
		anlzd = anlzd + 1;
		a_rdr_pun_analysis.analyses (anlzd) = rdr_pun_trans_table (i);
		a_is_interesting = "1"b;
		end;
	end;

	if fixed (substr (det_stats, 44, 3), 3) > 1 & fixed (substr (det_stats, 44, 3), 3) <= 7 then do;
	     anlzd = anlzd + 1;
	     a_rdr_pun_analysis.analyses (anlzd) = "Board Code = " || board_code (fixed (substr (det_stats, 44, 3), 3));
	     a_is_interesting = "1"b;
	     end;

fill_rdr_pun_struct:
	number_analyzed = anlzd;

	if (^rsnnl_sw & ^rs_sw) then do;
	     call hcs_$make_seg ("", "analyze_detail_stat_.temp", "", 10, rdr_pun_analp, xcode);

	     auto_analp = rdr_pun_analp;
	     rdr_pun_analysis.rdr_pun_analysis_version = analyze_det_stat_info_version_1;
	     rdr_pun_analysis.num_analyzed = anlzd;
	     rdr_pun_analysis.is_interesting_rdr_pun = a_is_interesting;
	     rdr_pun_analysis.rdr_pun_model = a_rdr_pun_analysis.rdr_pun_model;

	     if number_analyzed > 0
	     then do j = 1 to number_analyzed;
		rdr_pun_analysis.analyses (j) = a_rdr_pun_analysis.analyses (j);
	     end;

	     else rdr_pun_analysis.analyses (*) = "";

	     return;
	     end;

	if (rsnnl_sw | rs_sw) then do;
	     do j = 1 to number_analyzed;
		message = message || a_rdr_pun_analysis.analyses (j);
	     end;
	     if message ^= "" then do;
		if rs_sw then message = message || NEW_LINE;
		is_interesting = a_is_interesting;
		end;
	     else is_interesting = "0"b;
	     end;


	return;



not_yet:
	code = error_table_$unimplemented_version;
	return;
     end anal_rdr_pun;


%page;
anal_tape_:
     proc;

dcl  tks fixed bin init (0);
dcl  (valid, att_sw, da_alert, cmts, tracks_v) bit (1) init ("0"b);
dcl  mpc_model fixed bin init (0);
dcl  dev_type fixed bin init (0);
dcl  trk9_tbl (9) char (2) internal static options (constant) init ("0-", "1-", "2-", "3-", "4-", "5-", "6-", "7-", "P-");

dcl  trk7_tbl (9) char (2) internal static options (constant) init ("", "", "2-", "3-", "4-", "5-", "6-", "7-", "P-");

dcl  trk9_idx (9) fixed bin int static options (constant) init (5, 7, 9, 13, 1, 17, 3, 15, 11);

dcl  trk7_idx (9) fixed bin int static options (constant) init (0, 0, 7, 9, 11, 13, 15, 17, 5);

dcl  ext_stats (26) bit (8) unal based (ext_ptr);
dcl  ext_ptr ptr;
dcl  curr_mode char (1) init ("");
dcl  (str1, str2, str3) bit (9);
dcl  fdmask9 bit (9) init ("111111111"b);		/* mask for frame drop 9trk */
dcl  fdmask7 bit (9) init ("001111111"b);		/* mask for frame drop 7trk */
dcl  curr_dens char (2) init ("");


	a_tape_analysis.mth_model = "";
	a_tape_analysis.density = 0;
	a_tape_analysis.operation = "";
	a_tape_analysis.trks_in_err = "------------------";
	a_tape_analysis.dbie_array (*) = 0;
	a_tape_analysis.anal (*) = "";
	a_tape_analysis.num_tracks = 0;
	anlzd = 0;
	statp = addr (iom_stats);
	mpc_model = 0;

/*  This routine scans the config deck to see if the tape mpc is a mtc500
   If it is then it sets the switch that disables intrepreting the controller
   status, as the 500 doesn't have this available....       */

	prph_tap_cardp = null ();
	call config_$find_periph (substr (name, 1, 4), prph_tap_cardp);
	if prph_tap_cardp = null () then do;		/* device nolonger configured */
	     code = error_table_$resource_unknown;
	     return;
	     end;
	call find_controller (prph_tap_card.iom, prph_tap_card.chan);
	if mpc_cardp = null () & ipc_cardp = null () then return;
						/* not MPC/FIPS driven */
	if fips_controller then do;			/* handle fips differently */
	     call anal_fips_tape_;
	     goto fill_struct;
	     end;

	mpc_model = mpc_card.model;

	if stat_maj = "0010"b			/* don't try to analyze tkie data for this one */
	then if substr (stat_min, 4, 1) = "1"b then do;	/* dev in standby */
STDBY:
		anlzd = 0;
		code = error_table_$request_not_recognized;
		return;
		end;



	if (stat_maj = "1011"b) &			/* MPC data alert */
	     (stat_min = "100000"b)			/* margin cond */
	then att_sw = "1"b;

	else if (stat_maj = "0010"b) &		/* DEV Attention */
	     (substr (stat_min, 3, 1) = "1"b |		/* dev fault */
	     substr (stat_min, 2, 1) = "1"b)		/* blank tape on write */
	then att_sw = "1"b;

	else if (stat_maj = "1010"b) &		/* MPC Attention */
	     (substr (stat_min, 2, 1) = "1"b)		/* dev malfunction */
	then att_sw = "1"b;

	else if (stat_maj = "0011"b) &		/* dev data alert */
	     (substr (stat_min, 5, 2) = "11"b |		/* bit detected during erase */
	     substr (stat_min, 3, 1) = "1"b |		/* lateral parity */
	     substr (stat_min, 2, 1) = "1"b)		/* longitudinal parity */
	then da_alert = "1"b;

	else if (stat_maj = "1011"b) &		/* mpc data alert */
	     (fixed (stat_min, 6) = 8 |		/* id-burst write error */
	     fixed (stat_min, 6) = 9 |		/* preamble error */
	     fixed (stat_min, 6) = 16 |		/* multi-track error */
	     fixed (stat_min, 6) = 17 |		/* skew error */
	     fixed (stat_min, 6) = 18 |		/* postamble error */
	     fixed (stat_min, 6) = 19)		/* nrzi CCC error */
	then da_alert = "1"b;

	else if (stat_maj = "0100"b) &		/* eof */
	     (fixed (stat_min, 6) = 63)		/* data alert */
	then da_alert = "1"b;

	else if (stat_maj = "1010"b) &		/* MPC Attention */
	     (substr (stat_min, 3, 2) = "11"b)		/* TCA malfunction */
	then da_alert = "1"b;			/* not really, but will */
						/* allow detail register checking */

	else do;
	     anlzd = 0;
	     code = error_table_$request_not_recognized;
	     return;
	     end;


	dev_type = 0;

	if substr (det_stats, 7, 1) = "1"b
	then					/* dev in standby */
	     go to STDBY;				/* det stat worthless */

	if substr (det_stats, 17, 3) = "000"b then do;
	     a_tape_analysis.density = 1600;
	     curr_dens = "pe";
	     end;

	else if substr (det_stats, 17, 3) = "001"b then do;
	     curr_dens = "gc";
	     a_tape_analysis.density = 6250;
	     end;

	else do;
	     curr_dens = "nr";
	     a_tape_analysis.density = 800;
	     end;


	if substr (det_stats, 12, 1) = "1"b then do;
	     curr_mode = "";
	     a_tape_analysis.operation = "Rewind";
	     end;


	else if substr (det_stats, 10, 1) = "1"b then do;
	     curr_mode = "W";
	     a_tape_analysis.operation = "Write";
	     end;


	else if substr (det_stats, 10, 1) = "0"b then do;
	     curr_mode = "R";
	     a_tape_analysis.operation = "Read";
	     end;


	if substr (det_stats, 27, 1) = "0"b
	then					/* dev is a mtu400/500 */
	     dev_type = 500;

	else if substr (det_stats, 53, 4) = "0100"b
	then					/* dev is a MTU600 (OKC) type */
	     dev_type = 600;

	else if substr (det_stats, 53, 4) = "1000"b
	then					/* dev is a mtu610 (MPI) */
	     dev_type = 610;

	else if substr (det_stats, 53, 4) = "0110"b
	then					/* dev is a mtu640 MTUMPT (STC) */
	     dev_type = 640;

	if dev_type ^= 0 then a_tape_analysis.mth_model = "MTH" || ltrim (rtrim (char (dev_type)));


	if substr (det_stats, 26, 1) = "1"b then tks = 1; /* 1 = 9 trk, 0 = 7 trk drive */
	if tks = 1
	then a_tape_analysis.num_tracks = 9;
	else a_tape_analysis.num_tracks = 7;

	if att_sw then go to dev_model (dev_type);

	if da_alert then go to data_alert;

	if (rs_sw | rsnnl_sw) then do;
	     message = "";
	     is_interesting = "0"b;
	     end;

	return;

dev_model (0):
	code = error_table_$resource_type_inappropriate;
	a_is_interesting = "0"b;
	return;
%page;
dev_model (500):
	begin;

dcl  raw_status bit (208) based (addr (det_stats));
dcl  int_status bit (47);


dcl  trans_table_mth500 (47) char (35) varying internal static options (constant) init ("Device Fault: ",
						/* byte 0,bit 0 */
	"Command Code Error. ",			/*      ,bit 1 */
	"Write Echo Error. ",			/*      ,bit 2 */
	"Multiple BOT Status. ",			/*      ,bit 3 */
	"Margin Condition: ",			/*      ,bit 7 */
	"Load air failure. ",			/* byte 6,bit 1 */
	"File hub engage failure. ", "Window failed to shut. ", "Vacuum start-up failure. ", "File hub open. ",
	"Cannister failed to shut. ", "Semi-Auto thread-wrap failure. ", "Auto thread-wrap failure. ",
	"Machine Col. load failure. ", "File Col. load failure. ", "Door Interlock Open. ",
						/* byte 7, bit2 */
	"Window Interlock Open. ",			/*      , bit 3 */
	"Hi Tape-File Col. ",			/*      , bit 4 */
	"Hi Tape-Mach Col. ",			/*    , bit 5 */
	"Lo Tape-File Col. ",			/*      , bit  6 */
	"Lo Tape-Mach Col. ",			/*      , bit 7 */
	"Vacuum Loss. ",				/* byte 8, bit 0 */
	"Col Vacuum-Marginal. ",			/*     , bit 1 */
	"LTOR Lamp. ",				/*      , bit 2 */
	"BOT/EOT Lamp. ",				/*      , bit 3 */
	"Cannister Shut Failure. ",			/*      , bit 4 */
	"File Hub Release Failure. ",			/*      , bit 5 */
	"Erase Current Failure. ",			/*      , bit 6 */
	"Window Safety Bar. ",			/*      , bit 7 */
	"Over Temp (LOGIC). ",			/* byte 9, bit 0 */
	"Over Temp (CAPSTAIN). ",			/*      , bit 1 */
	"DC Breaker Switched. ",			/*      , bit 2 */
	"+5V (OV/UV) Failure. ",			/*      , bit 3 */
	"-24V (OV/UV) Failure. ",			/*      , bit 4 */
	"+12V (OV/UV) Failure. ",			/*      , bit 5 */
	"-12V (OV/UV) Failure. ",			/*      , bit 6 */
	"+24V (OV/UV) Failure. ",			/*      , bit 7 */
	"Over Speed. ",				/* byte 10, bit 0 */
	"Under Speed. ",				/*       , bit 1 */
	"+5V (Marginal). ",				/*       , bit 4 */
	"-24V (Marginal). ",			/*       , bit 5 */
	"+12V (Marginal). ",			/*       , bit 6 */
	"-12v (Marginal). ",			/*       , bit 7 */
	"File Reel CONTROL Malfunction. ",		/* byte 15, bit 2 */
	"Lo Tape-File. ",				/* byte 16, bit 3 (mtc500 only) */
	"Lo Tape-Mach. ",				/*       , bit 7  "" */
	"Mach Reel CONTROL Malfunction. ");		/* byte 18 bit 2 (mtc500 only) */

	     anlzd = 0;
	     substr (int_status, 1, 4) = substr (raw_status, 1, 4);
	     substr (int_status, 5, 1) = substr (raw_status, 8, 1);
	     substr (int_status, 6, 10) = substr (raw_status, 49, 10);
	     substr (int_status, 16, 24) = substr (raw_status, 59, 24);
	     substr (int_status, 40, 4) = substr (raw_status, 85, 4);
	     substr (int_status, 44, 1) = substr (raw_status, 123, 1);
	     substr (int_status, 45, 1) = substr (raw_status, 132, 1);
	     substr (int_status, 46, 1) = substr (raw_status, 136, 1);
	     substr (int_status, 47, 1) = substr (raw_status, 147, 1);

	     do i = 2 to 4;
		if substr (int_status, i, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth500 (i);
		     a_is_interesting = "1"b;
		     end;
	     end;

	     if substr (int_status, 1, 1) = "1"b then do; /* dev fault */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth500 (1);

		do i = 6 to 37;			/* cycle thru dev fault bits */
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth500 (i);
			a_is_interesting = "1"b;
			end;
		end;

		if substr (int_status, 44, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth500 (44);
		     a_is_interesting = "1"b;
		     end;


		if mpc_model = 500 then do;		/* these bits only valid for mtc500 mpc */
		     if substr (int_status, 45, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth500 (45);
			a_is_interesting = "1"b;
			end;

		     if substr (int_status, 46, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth500 (46);
			a_is_interesting = "1"b;
			end;

		     if substr (int_status, 47, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth500 (47);
			a_is_interesting = "1"b;
			end;
		     end;

		end;				/* end dev fault checks */

	     if substr (int_status, 5, 1) = "1"b then do; /* now check for margin cond */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth500 (5);

		do i = 38 to 43;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth500 (i);
			a_is_interesting = "1"b;
			end;
		end;
		end;

	     go to fill_struct;


	end;					/* end begin bolck mth500 */
%page;
dev_model (600):
	begin;

dcl  raw_status bit (208) based (addr (det_stats));
dcl  int_status bit (24);
dcl  trans_table_mth600 (39) char (35) varying internal static options (constant) init ("Device Fault: ",
						/* byte 0, bit 0 */
	"Command Code Error. ",			/*      ,bit 1 */
	"Write Echo Error. ",			/*      ,bit 2 */
	"Multiple BOT Status. ",			/*     ,bit 3 */
	"Margin Condition: ",			/*      ,bit 7 */
	"Column Vacuum Failure. ",			/* byte 6,bit 0 */
	"Main Blower Failure. ",			/*      ,bit 1 */
	"Overtemp (Deck Hot). ",			/*      ,bit 2 */
	"TMC ROM Error. ",				/*      ,bit 3 */
	"Erase Current Failure. ",			/* byte 8,bit 0 */
	"Door Open. ",				/*     ,bit 1 */
	"Capstan Blower Failure. ",			/*      ,bit 2 */
	"Air Bearing Failure. ",			/*      ,bit 3 */
	"Marginal Gap. ",				/*      ,bit 7 */
	"Duty Cycle Exceeded. ",			/* byte 9, bit 7 */
	"Power window failure. ", "File hub failure. ", "Cannister failure. ", "Load retry failure. ",
	"BOT/EOT Sensor Failure. ", "LTOR Sensor Failure. ", "Hi Tape Sensor Failure. ", "Column load failure. ",
	"Thread-wrap failure. ", "Load/Unload ROM addr. failure. ", "Hi Tape (File Column). ",
	"Lo Tape (File Column). ", "Hi Tape (Machine Column). ", "Lo Tape (Machine Column). ",
	"Mach/File Tach Failure. ", "Vacuum Failure. ", "Column Sensor 4 Failure. ", "+5V Marginal. ", "+5V Fault. ",
	"+/- 12V Marginal. ", "+/- 12V Fault. ", "+24V Fault. ", "Circuit Breaker Tripped. ",
	"Mach/File Reel Malfunction. ");


dcl  x fixed bin;

	     anlzd = 0;
	     substr (int_status, 1, 4) = substr (raw_status, 1, 4);
	     substr (int_status, 5, 1) = substr (raw_status, 8, 1);
	     substr (int_status, 6, 4) = substr (raw_status, 49, 4);
	     substr (int_status, 10, 4) = substr (raw_status, 65, 4);
	     substr (int_status, 14, 1) = substr (raw_status, 72, 1);
	     substr (int_status, 15, 1) = substr (raw_status, 80, 1);
	     substr (int_status, 16, 8) = substr (raw_status, 57, 8);
	     substr (int_status, 24, 1) = substr (raw_status, 93, 1);


	     do i = 2 to 4;
		if substr (int_status, i, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (i);
		     a_is_interesting = "1"b;
		     end;
	     end;

	     if substr (int_status, 1, 1) = "1"b |	/* dev fault */
		substr (int_status, 5, 1) = "1"b then do;
						/* or margin cond */
		anlzd = anlzd + 1;
		if substr (int_status, 1, 1) = "1"b then do;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (1);
		     a_is_interesting = "1"b;
		     end;

		else if substr (int_status, 5, 1) = "1"b then do;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (5);
		     a_is_interesting = "1"b;
		     end;

		do i = 6 to 15;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth600 (i);
			a_is_interesting = "1"b;
			end;
		end;

		if substr (int_status, 23, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (38);
		     a_is_interesting = "1"b;
		     go to fill_struct;
		     end;

		if substr (int_status, 24, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (39);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "10000"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (16);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "01000"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (17);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "11000"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (18);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "00100"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (19);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "10100"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (20);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "01100"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (21);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 3) = "111"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (22);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "00010"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (23);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "10010"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (24);
		     a_is_interesting = "1"b;
		     end;

		if substr (int_status, 16, 5) = "01010"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (25);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 2) = "10"b
		then if substr (int_status, 20, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth600 (26);
			a_is_interesting = "1"b;
			end;


		if substr (int_status, 16, 2) = "01"b
		then if substr (int_status, 20, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth600 (27);
			a_is_interesting = "1"b;
			end;


		if substr (int_status, 18, 3) = "101"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (28);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 18, 3) = "011"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (29);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "11010"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (30);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "00110"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (31);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 16, 5) = "10110"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (32);
		     a_is_interesting = "1"b;
		     end;


		x = fixed (substr (int_status, 1, 1) || substr (int_status, 5, 1), 2);

		if x > 0 then go to volt_check_mth600 (x);

		go to fill_struct;


volt_check_mth600 (1):
		if substr (int_status, 21, 2) = "10"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (33);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 21, 2) = "01"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (35);
		     a_is_interesting = "1"b;
		     end;


		go to fill_struct;


volt_check_mth600 (2):
		if substr (int_status, 21, 2) = "10"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (37);
		     a_is_interesting = "1"b;
		     end;


		go to fill_struct;

volt_check_mth600 (3):
		if substr (int_status, 21, 2) = "10"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (34);
		     a_is_interesting = "1"b;
		     end;


		if substr (int_status, 21, 2) = "01"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth600 (36);
		     a_is_interesting = "1"b;
		     end;


end_mth600_attn:
		end;				/* end dev fault/malf checks */

	end;					/* end begin block for mth600 */
	go to fill_struct;

%page;
dev_model (610):
	begin;
dcl  raw_status bit (208) based (addr (det_stats));
dcl  int_status bit (19);
dcl  trans_table_mth610 (19) char (65) varying internal static options (constant)
	init ("Device Fault: ", "Command Code Error. ", "Signal Fault: ", "Multiple BOT Status. ",
	"Marginal Condition: ", "Incorrect Speed Detected. ", "Main Blower Failure. ", "Over Temp. ",
	"Low Air Bearing Pressure. ", "Erase Current Failure. ", "Door Open Switch. ", "Write Current Failure. ",
	"Auto Hub Air Pressure Failure. ", "Fibre Optics Failure. ", "Voltage Failure. ",
	"Column Vacuum Failure (Soft Servo, Capstan Speed or Col Sensor). ", "Load/Unload Failure. ",
	"Speed Status (<95% or >105%). ", "GCR AGC @ Max while SIG AMP below reference. ");

	     anlzd = 0;
	     substr (int_status, 1, 4) = substr (raw_status, 1, 4);
	     substr (int_status, 5, 1) = substr (raw_status, 8, 1);
	     substr (int_status, 6, 4) = substr (raw_status, 49, 4);
	     substr (int_status, 10, 8) = substr (raw_status, 57, 8);
	     substr (int_status, 18, 1) = substr (raw_status, 103, 1);
	     substr (int_status, 19, 1) = substr (raw_status, 118, 1);

	     if substr (int_status, 2, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (2);
		a_is_interesting = "1"b;
		end;


	     if substr (int_status, 4, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (4);
		a_is_interesting = "1"b;
		end;


	     if substr (int_status, 3, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (3);
		a_is_interesting = "1"b;
		end;


	     if substr (int_status, 1, 1) = "1"b then do; /* dev fault */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (1);

		do i = 10 to 17;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth610 (i);
			a_is_interesting = "1"b;
			end;
		end;
		go to end_mth610_attn;
		end;				/* end dev fault checks */

	     if substr (int_status, 5, 1) = "1"b then do; /* margin condition */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (5);

		do i = 6 to 9;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth610 (i);
			a_is_interesting = "1"b;
			end;
		end;

		if substr (int_status, 18, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth610 (18);
		     a_is_interesting = "1"b;
		     end;
		end;				/* end margin cond checks */

	     if substr (int_status, 19, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth610 (19);
		a_is_interesting = "1"b;
		end;


end_mth610_attn:
	end;					/* end begin block for mth610 */
	go to fill_struct;
%page;
/* Routine to analyze detail status for the MTUMPT (STC) tape drive */

dev_model (640):
	begin;

dcl  raw_status bit (208) based (addr (det_stats));
dcl  int_status bit (18);
dcl  CODE char (2) init ("");
dcl  trans_table_mth640 (17) char (31) varying internal static options (constant)
	init ("Device Fault: ", "Command Code Error. ", "Command Even Parity: ", "Signal Fault:",
	"Multiple BOT Status. ", "Marginal Condition: ", "Write Current Failure. ", "Erase Current Failure. ",
	"Air Pressure/Vacuum Failure. ", "Door Open. ", "Regulated Voltage Missing. ", "Un-Regulated Voltage Missing. ",
	"Processor Failure. ", "Incorrect Speed Detected. ", "Marginal Gap. ", "Marginal Air Bearing Pressure. ",
	"Marginal Voltage. ");

dcl  sub_test1 (7) char (21) var int static options (constant)
	init ("Load Fault. ", "Unload Fault. ", "Write Inhibit Fault. ", "Multiple BOT Fault. ", "Runaway Fault. ",
	"Rewind Fault. ", "Z-80 Interrupt. ");


	     anlzd = 0;
	     substr (int_status, 1, 2) = substr (raw_status, 1, 2);
	     substr (int_status, 3, 1) = substr (raw_status, 16, 1);
	     substr (int_status, 4, 2) = substr (raw_status, 3, 2);
	     substr (int_status, 6, 1) = substr (raw_status, 8, 1);
	     substr (int_status, 7, 3) = substr (raw_status, 49, 3);
						/* ^(door closed) */
	     substr (int_status, 10, 1) = ^(substr (raw_status, 52, 1));
	     substr (int_status, 11, 2) = substr (raw_status, 57, 2);
	     substr (int_status, 13, 1) = substr (raw_status, 80, 1);
	     substr (int_status, 14, 3) = substr (raw_status, 41, 3);
	     substr (int_status, 17, 1) = substr (raw_status, 59, 1);


	     if substr (int_status, 1, 1) = "1"b then do; /* dev fault */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth640 (1);

		do i = 7 to 14;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth640 (i);
			a_is_interesting = "1"b;
			end;
		end;
		if substr (raw_status, 62, 3) ^= "0"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = sub_test1 (bin (substr (raw_status, 62, 3), 3));
		     end;
		if substr (raw_status, 65, 8) ^= "0"b then do;
		     anlzd = anlzd + 1;
		     call ioa_$rsnnl ("^2.4b", CODE, 2, substr (raw_status, 65, 8));
		     a_tape_analysis.anal (anlzd) = "FAULT CODE = " || CODE;
		     end;


		go to end_mth640_attn;		/* other faults do not matter */
		end;				/* end dev fault checks */


	     if substr (int_status, 6, 1) = "1"b then do; /* margin condition */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth640 (6);

		do i = 15 to 17;
		     if substr (int_status, i, 1) = "1"b then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = trans_table_mth640 (i);
			a_is_interesting = "1"b;
			end;
		end;
		end;


	     do i = 2 to 3;				/* check command errors */
		if substr (int_status, i, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = trans_table_mth640 (i);
		     a_is_interesting = "1"b;
		     end;
	     end;


	     if substr (int_status, 5, 1) = "1"b then do; /* multiple bot? */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth640 (5);
		a_is_interesting = "1"b;
		end;


	     if substr (int_status, 4, 1) = "1"b then do; /* signal fault ? */
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = trans_table_mth640 (4);
		a_is_interesting = "1"b;
		end;


end_mth640_attn:
	end;					/* end begin block for mth640 */
end_attn:
	go to fill_struct;
%page;

data_alert:
dcl  rc_misc_reg (8) char (25) varying internal static options (constant)
	init ("C2 1. ", "C2 0. ", "Illeg Code Conv Char. ", "", "Lateral Parity Err. ", "RC Reg R3 Par Err. ",
	"RC Reg R4 Par Err. ", "Data Out Par Err. ");

dcl  FRAME_DROP char (18) init ("----FRAME DROP----");

	anlzd = 0;


	if mpc_model < 601
	then					/* mpc ext stats bytes 16-25 valid only for 601/610 */
	     go to fill_struct;			/* not mtc500 */

	if curr_dens ^= "nr" then go to not_nrzi;

Dens (800):					/* NRZI Decode */
	ext_ptr = addr (det_stats);


	if curr_mode ^= "W"
	then					/* write treated differently */
	     go to nrzi_read;
nrzi_write:					/* **************************************************************************
						   *   join the hi and lo clip error bytes to their respective parity bits   *
						   *   for an xor compare of which bit(s) didn't make it		         *
						   ************************************************************************** */
	str1 = substr (ext_stats (19), 1, 8) || substr (ext_stats (18), 2, 1);
	str2 = substr (ext_stats (20), 1, 8) || substr (ext_stats (18), 3, 1);
	str3 = bool (str1, str2, "0110"b);		/* XOR to get diff */
	if str3 = "0"b then go to nrzi_read;

	anlzd = anlzd + 1;
	a_tape_analysis.anal (anlzd) = "HI/LO Clip compare error. ";

	if tks = 0
	then					/* 7 track drive */
	     do j = 3 to 9;
	     if substr (str3, j, 1) = "1"b then do;
		substr (a_tape_analysis.trks_in_err, trk7_idx (j), 2) = trk7_tbl (j);
		a_tape_analysis.dbie_array (j) = 1;
		end;
	end;

	else do j = 1 to 9;				/* same thing for 9 track */
	     if substr (str3, j, 1) = "1"b then do;
		substr (a_tape_analysis.trks_in_err, trk9_idx (j), 2) = trk9_tbl (j);
		a_tape_analysis.dbie_array (j) = 1;
		end;
	end;

	go to end_tkie_sum;

nrzi_read:
	str1 = substr (ext_stats (17), 1, 8) || substr (ext_stats (18), 1, 1);

	if tks = 0 then do;
	     if str1 = fdmask7 then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "Frame Drop. ";
		a_tape_analysis.trks_in_err = FRAME_DROP;
		go to end_tkie_sum;
		end;

	     else do j = 3 to 9;
		if substr (str1, j, 1) = "1"b then do;
		     substr (a_tape_analysis.trks_in_err, trk7_idx (j), 2) = trk7_tbl (j);
		     a_tape_analysis.dbie_array (j) = 1;
		     end;
	     end;
	     end;

	else do;					/* must be a 9 track drive */

	     if str1 = fdmask9 then do;
		a_tape_analysis.trks_in_err = FRAME_DROP;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "Frame Drop. ";
		go to end_tkie_sum;
		end;

	     else do j = 1 to 9;
		if substr (str1, j, 1) = "1"b then do;
		     substr (a_tape_analysis.trks_in_err, trk9_idx (j), 2) = trk9_tbl (j);
		     a_tape_analysis.dbie_array (j) = 1;
		     end;
	     end;
	     end;

	go to end_tkie_sum;


not_nrzi:
Dens (6250):					/* Group Code Recording (GCR) decode */
Dens (1600):					/* Phase Encoded (PE) Decode */
	ext_ptr = addr (det_stats);
	anlzd = 0;


	if curr_dens = "gc" then do;

	     if substr (ext_stats (15), 6, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "GCR AGC @ Max while SIG AMP below reference. ";
		a_is_interesting = "1"b;
		end;

	     if substr (ext_stats (20), 3, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "3 or more tracks in error. ";
		go to ck_skew;
		end;

	     if substr (ext_stats (20), 2, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "2 tracks in error. ";
		go to ck_skew;
		end;

	     if substr (ext_stats (20), 1, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "1 track in error. ";
		end;



ck_skew:
	     if curr_mode = "W" then do;

		if substr (ext_stats (20), 5, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "10 Chars of Skew. ";
		     go to decode_tkie;
		     end;

		if substr (ext_stats (20), 4, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "5 Chars of Skew. ";
		     go to decode_tkie;
		     end;
		end;

	     else if curr_mode = "R" then do;
		if substr (ext_stats (20), 6, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "25 Chars of Skew. ";
		     go to decode_tkie;
		     end;
		end;
	     end;					/* end 6250 specifics */



	if (mpc_model = 610) & (curr_dens = "pe") then do;

	     if substr (ext_stats (23), 7, 1) = "1"b then do;
		anlzd = anlzd + 1;
		if curr_mode = "R"
		then a_tape_analysis.anal (anlzd) = "PE Multi-Track Err. ";
		else a_tape_analysis.anal (anlzd) = "PE Single-Track Err. ";
		end;


	     if curr_mode ^= "W" then go to decode_tkie;

	     if substr (ext_stats (23), 8, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "PE Buffer Overload. ";
		go to decode_tkie;
		end;


	     end;


	else if mpc_model = 601
	then if substr (ext_stats (21), 4, 1) = "0"b then do;

		if curr_mode ^= "W" then go to decode_tkie;

		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "PE Write Window Err. ";
		go to decode_tkie;
		end;

decode_tkie:
	str1 = substr (ext_stats (17), 1, 8) || substr (ext_stats (18), 1, 1);

	if str1 = fdmask9 then do;
	     a_tape_analysis.trks_in_err = FRAME_DROP;
	     anlzd = anlzd + 1;
	     a_tape_analysis.anal (anlzd) = "Frame Drop. ";
	     go to end_tkie_sum;
	     end;

	do j = 1 to 9;				/* must have valid tkie data, get it */
	     if substr (str1, j, 1) = "1"b then do;
		substr (a_tape_analysis.trks_in_err, trk9_idx (j), 2) = trk9_tbl (j);
		a_tape_analysis.dbie_array (j) = 1;
		end;
	end;
end_tkie_sum:
	if mpc_model = 610 then do;

	     if substr (ext_stats (21), 3, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "DOS Drop. ";
		end;

	     if substr (ext_stats (22), 7, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "Echo-Read Dropout. ";
		end;


	     if substr (ext_stats (23), 6, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "TTE MTH->MPC. ";
		end;


/* now check the IE register */

	     if substr (ext_stats (26), 4, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "DO Parity Err. ";
		a_is_interesting = "1"b;
		end;


	     if substr (ext_stats (26), 7, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "Write Buffer Parity Err. ";
		a_is_interesting = "1"b;
		end;


	     if substr (ext_stats (26), 8, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "RO Parity Err. ";
		a_is_interesting = "1"b;
		end;


	     do j = 6 to 8;				/* check RC misc register */
		if substr (ext_stats (24), j, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = rc_misc_reg (j);
		     a_is_interesting = "1"b;
		     end;
	     end;


/* Bypass the next check until HW eng define the meaning of these bits

   do j = 1 to 4;			 now do the RC board id
   if substr (ext_stats (25), (j+4), 1) = "1"b then do;
   anlzd = anlzd +1;
   a_tape_analysis.anal (anlzd) =
   rc_bd_id (j);
   end;
*/


	     end;					/* end mtp610 specifics */


	else if mpc_model = 601 then do;		/* check mtp601 specifics */

	     if substr (ext_stats (21), 2, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "TTE MTH->MPC. ";
		end;


	     if substr (ext_stats (21), 3, 1) = "1"b then do;
		anlzd = anlzd + 1;
		a_tape_analysis.anal (anlzd) = "Illegal Char. ";
		end;


	     if curr_dens = "nr" then do;

		if substr (ext_stats (22), 1, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "Hi Clip Parity Err. ";
		     a_is_interesting = "1"b;
		     end;


		if substr (ext_stats (22), 2, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "Lo Clip Parity Err. ";
		     a_is_interesting = "1"b;
		     end;
		end;


	     else if curr_dens = "pe" then do;
		if substr (ext_stats (21), 5, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "Skew Error. ";
		     end;


		if substr (ext_stats (21), 6, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "Postamble Error. ";
		     end;

		if substr (ext_stats (22), 2, 1) = "1"b then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = "PE Deskew Char Parity Bit Err. ";
		     end;
		end;

	     end;					/* mtp601 specifics */

fill_struct:
	number_analyzed = anlzd + 1;

	if (^rsnnl_sw & ^rs_sw) then do;
	     call hcs_$make_seg ("", "analyze_detail_stat_.temp", "", 10, tape_analp, xcode);
	     auto_analp = tape_analp;
	     tape_analysis.tape_analysis_version = analyze_det_stat_info_version_2;
	     tape_analysis.num_analyzed = anlzd;
	     tape_analysis.is_interesting_tape = a_is_interesting;
	     tape_analysis.fips_controller = fips_controller;
	     tape_analysis.pad = ""b;
	     tape_analysis.mth_model = a_tape_analysis.mth_model;
	     tape_analysis.num_tracks = a_tape_analysis.num_tracks;
	     tape_analysis.tracks_in_error = a_tape_analysis.trks_in_err;
	     tape_analysis.dbie_array = a_tape_analysis.dbie_array;
	     tape_analysis.density = a_tape_analysis.density;
	     tape_analysis.operation = a_tape_analysis.operation;

	     if number_analyzed > 0
	     then do j = 1 to number_analyzed;
		tape_analysis.analyses (j) = a_tape_analysis.anal (j);
	     end;

	     else tape_analysis.analyses (*) = "";
	     return;
	     end;


	if (rsnnl_sw | rs_sw) then do;
	     if a_is_interesting
	     then do j = 1 to number_analyzed;
		message = message || a_tape_analysis.anal (j);
	     end;
	     if message ^= "" then do;
		if rs_sw then message = message || NEW_LINE;
		is_interesting = a_is_interesting;
		end;
	     else is_interesting = "0"b;
	     end;
	return;
%page;
anal_fips_tape_:
	proc;

dcl  (dev_no, dev_no_idx) fixed bin;
dcl  (ft_in_pe, ft_can_run_6250) bit (1) init ("0"b);
dcl  ft_general_err_bits bit (8) init (""b);
dcl  ft_unit_err_bits bit (9) init (""b);
dcl  ft_data_err_bits bit (23) init (""b);

dcl  ft_general_table (8) char (65) varying internal static options (constant)
	init ("Command Reject ", "Bus Out Check ", "Equipment Check ", "Reject Tape Unit ", "EOT Mark Detected ",
	"Tape Unit Check ", "Channel Buffer Check ", "Command Status Reject ");

dcl  ft_unit_table (9) char (65) varying internal static options (constant)
	init ("Intervention Required ", "Micro Hardware Check ", "Column Out ", "File Column Check ",
	"Machine Column Check ", "Reset Key ", "Load Check ", "Tach Start Failure ", "Velocity Check ");

dcl  ft_data_table (23) char (65) varying internal static options (constant)
	init ("Data Check ", "Overrun ", "Word Count Zero ", "Noise ", "Not Capable ", "R/W VRC ", "MTE/LRC ",
	"Skew Error ", "EDC/CRC ", "ENV/ECC ", "C/P Compare ", "Write VRC ", "WTM Check ", "ID Burst Check ",
	"Partial Record ", "Postamble Error ", "Write Check ", "DSE Check ", "Erase Check ", "IBG Detected ",
	"Velocity Change ", "CRC III ", "Record NOT Detected ");

	     a_tape_analysis.num_tracks = 9;		/* all are 9-track */
	     dev_no = cv_dec_check_ (substr (name, 6, 2), code);
	     dev_no_idx = 0;
	     do j = 1 to 5 while (a_tape_analysis.mth_model = "");
		dev_no_idx = dev_no_idx + prph_tap_card.ndrives (j);
		if dev_no < dev_no_idx
		then a_tape_analysis.mth_model = "MTU" || ltrim (char (prph_tap_card.model (j)));
	     end;

	     ft_in_pe = substr (det_stats, 30, 1);
	     ft_can_run_6250 = substr (det_stats, 77, 1);
	     if ft_in_pe then a_tape_analysis.density = 1600;
	     else if ft_can_run_6250 then a_tape_analysis.density = 6250;
	     else a_tape_analysis.density = 800;

	     substr (ft_general_err_bits, 1, 1) = substr (det_stats, 1, 1);
	     substr (ft_general_err_bits, 2, 2) = substr (det_stats, 3, 2);
	     substr (ft_general_err_bits, 4, 2) = substr (det_stats, 34, 2);
	     substr (ft_general_err_bits, 6, 1) = substr (det_stats, 39, 1);
	     substr (ft_general_err_bits, 7, 1) = substr (det_stats, 75, 1);
	     substr (ft_general_err_bits, 8, 1) = substr (det_stats, 81, 1);

	     substr (ft_unit_err_bits, 1, 1) = substr (det_stats, 2, 1);
	     substr (ft_unit_err_bits, 2, 1) = substr (det_stats, 33, 1);
	     substr (ft_unit_err_bits, 3, 4) = substr (det_stats, 57, 4);
	     substr (ft_unit_err_bits, 7, 1) = substr (det_stats, 64, 1);
	     substr (ft_unit_err_bits, 8, 1) = substr (det_stats, 86, 1);
	     substr (ft_unit_err_bits, 9, 1) = substr (det_stats, 88, 1);

	     substr (ft_data_err_bits, 1, 3) = substr (det_stats, 5, 3);
	     substr (ft_data_err_bits, 4, 1) = substr (det_stats, 9, 1);
	     substr (ft_data_err_bits, 5, 1) = substr (det_stats, 16, 1);
	     substr (ft_data_err_bits, 6, 5) = substr (det_stats, 25, 5);
	     substr (ft_data_err_bits, 11, 1) = substr (det_stats, 32, 1);
	     substr (ft_data_err_bits, 12, 1) = substr (det_stats, 36, 1);
	     substr (ft_data_err_bits, 13, 2) = substr (det_stats, 43, 2);
	     substr (ft_data_err_bits, 15, 2) = substr (det_stats, 46, 2);
	     substr (ft_data_err_bits, 17, 1) = substr (det_stats, 50, 1);
	     substr (ft_data_err_bits, 18, 2) = substr (det_stats, 61, 2);
	     substr (ft_data_err_bits, 20, 1) = substr (det_stats, 65, 1);
	     substr (ft_data_err_bits, 21, 1) = substr (det_stats, 74, 1);
	     substr (ft_data_err_bits, 22, 1) = substr (det_stats, 76, 1);
	     substr (ft_data_err_bits, 23, 1) = substr (det_stats, 84, 1);

	     if ft_general_err_bits
	     then do i = 1 to 8;
		if substr (ft_general_err_bits, i, 1) then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = ft_general_table (i);
		     a_is_interesting = "1"b;
		     end;
	     end;

	     if ft_unit_err_bits
	     then do i = 1 to 9;
		if substr (ft_unit_err_bits, i, 1) then do;
		     anlzd = anlzd + 1;
		     a_tape_analysis.anal (anlzd) = ft_unit_table (i);
		     a_is_interesting = "1"b;
		     end;
	     end;

	     if ft_data_err_bits then do;
		if substr (det_stats, 14, 1)
		then a_tape_analysis.operation = "Write";
		else a_tape_analysis.operation = "Read";
		do i = 1 to 23;
		     if substr (ft_data_err_bits, i, 1) then do;
			anlzd = anlzd + 1;
			a_tape_analysis.anal (anlzd) = ft_data_table (i);
			a_is_interesting = "1"b;
			end;
		end;

		str1 = substr (det_stats, 17, 8) ||	/* add on P track check */
		     (^ft_in_pe & ^substr (det_stats, 14, 1) & (substr (det_stats, 17, 8) = ""b));
		if ^ft_in_pe & (substr (det_stats, 17, 8) = "03"b4)
		then a_tape_analysis.trks_in_err = "-Track Not Found-";
		else do j = 1 to 9;
		     if substr (str1, j, 1) = "1"b then do;
			substr (a_tape_analysis.trks_in_err, trk9_idx (j), 2) = trk9_tbl (j);
			a_tape_analysis.dbie_array (j) = 1;
			end;
		end;
		end;
	     if a_is_interesting & substr (det_stats, 177, 8) ^= ""b then do;
		anlzd = anlzd + 1;
		call ioa_$rsnnl ("Symptom_code=^2.4b ", a_tape_analysis.anal (anlzd), 16, substr (det_stats, 177, 8));
		end;
	     return;
	end anal_fips_tape_;
     end anal_tape_;
%page;
find_controller:
     proc (a_iom, a_chan);
dcl  a_iom fixed bin (3);
dcl  a_chan fixed bin (8);

	fips_controller = "0"b;
	ipc_cardp = null ();
	mpc_cardp = null ();
	do while ("1"b);
	     call config_$find (MPC_CARD_WORD, mpc_cardp);
	     if mpc_cardp = null () then goto check_for_fips;
	     do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.port (i).iom ^= -1);
		if (a_iom = mpc_card.port (i).iom) & (a_chan >= mpc_card.port (i).chan)
		     & (a_chan < mpc_card.port (i).chan + mpc_card.port (i).nchan)
		then return;
	     end;
	end;

check_for_fips:
	do while ("1"b);
	     call config_$find (IPC_CARD_WORD, ipc_cardp);
	     if ipc_cardp = null () then return;
	     if ipc_card.type = IPC_FIPS then do;
		if (a_iom = ipc_card.iom) & (a_chan >= ipc_card.chan) & (a_chan < ipc_card.chan + ipc_card.nchan)
		then do;
		     fips_controller = "1"b;
		     return;
		     end;
		end;
	end;
     end find_controller;
%page;
%include access_mode_values;
%page;
%include analyze_det_stat_info;
%page;
%include config_ipc_card;
%page;
%include config_mpc_card;
%page;
%include config_prph_card;
%page;
%include config_prph_tap_card;
%page;
%include config_prph_dsk_card;

     end analyze_detail_stat_;





		    disk_status_table_.alm          09/12/83  1116.3rew 09/12/83  1026.8       43263



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" DISK_STATUS_TABLE - Status Tables for Disk.
"	coded 7/7/75 by Noel I. Morris
"	modified 4/79 by R.J.C. Kissel to add major status 0,
"	   and new entry for major 13 sub 41 and 42 for MSU0501.

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


	include	status_table


" 

	status_table	disk,(1,1,1,1,1,1,0,0,1,0,1,1,0,1,0,0)

" 

	status_entry	1,(Channel Ready)

	substat_entry	1,000000,,(No substatus)
	substat_entry	1,000001,,(Retried 1 time)
	substat_entry	1,000010,,(Retried 2 times)
	substat_entry	1,000011,,(Retried 3 times)
	substat_entry	1,0010XX,,(Device in T&D)
	substat_entry	1,010000,,(EDAC correction performed)

" 

	status_entry	2,(Device Busy)

	substat_entry	2,000000,bk+rp,(Device positioning)
	substat_entry	2,100000,bk+rp,(Alternate channel in control)

" 

	status_entry	3,(Device Attention)

	substat_entry	3,000001,rp+hlt,(Write inhibited)
	substat_entry	3,000010,rp+hlt,(Seek incomplete)
	substat_entry	3,001000,rp+hlt,(Device fault)
	substat_entry	3,010000,rp+hlt,(Device in standby)
	substat_entry	3,100000,rp+hlt,(Device offline)

" 

	status_entry	4,(Device Data Alert)

	substat_entry	4,000001,bk+rp,(Transfer timing alert)
	substat_entry	4,000010,bk+rp,(Transmission parity alert)
	substat_entry	4,000100,rp+hlt,(Invalid seek address)
	substat_entry	4,0X1000,bk+rp,(Header verification failure)
	substat_entry	4,X1X000,bk+rp,(Check character alert)
	substat_entry	4,1X0000,bk+rp,(Compare alert)

" 

	status_entry	5,(End of File)

	substat_entry	5,000000,bk+rp,(Good track detected)
	substat_entry	5,0000X1,bk+rp,(Last consecutive block)
	substat_entry	5,00001X,bk+rp,(Sector count limit exceeded)
	substat_entry	5,000100,rp,(Defective trk-alternate assnd)
	substat_entry	5,001000,rp,(Defective trk-no alternate assnd)
	substat_entry	5,010000,rp,(Alternate track detected)

" 

	status_entry	6,(Command Reject)

	substat_entry	6,000001,rp+hlt,(Invalid operation code)
	substat_entry	6,000010,rp+hlt,(Invalid device code)
	substat_entry	6,000100,rp+hlt,(IDCW parity error)
	substat_entry	6,001000,rp+hlt,(Invalid instruction sequence)

" 

	status_entry	9,(Channel busy)


" 

	status_entry	11,(MPC Attention)

	substat_entry	11,000001,rp+hlt,(Configuration switch error)
	substat_entry	11,000010,rp+hlt,(Multiple devices)
	substat_entry	11,000011,bk+rp,(Illegal device number)
	substat_entry	11,001011,rp+hlt,(CA error or OPI down)
	substat_entry	11,001100,rp+hlt,(Unexpected EN1 interrupt)
	substat_entry	11,001101,rp+hlt,(CA EN1 error)
	substat_entry	11,001110,rp+hlt,(CA alert (no EN1))

" 

	status_entry	12,(MPC Data Alert)

	substat_entry	12,000001,bk+rp,(Transmission parity alert)
	substat_entry	12,000010,bk+rp,(Inconsistent command)
	substat_entry	12,000011,bk+rp,(Sum check error)
	substat_entry	12,000100,bk+rp,(Byte locked out)
	substat_entry	12,001000,bk+rp,(Buffer parity)
	substat_entry	12,001001,bk+rp,(Aux cycle code error (CRC))
	substat_entry	12,001010,bk+rp,(Count field uncorrectable)
	substat_entry	12,001110,bk+rp,(EDAC parity error)
	substat_entry	12,010001,bk+rp,(Sector size error)
	substat_entry	12,010010,rp+hlt,(Nonstandard sector size)
	substat_entry	12,010011,rp+hlt,(Search alert (first search))
	substat_entry	12,010100,rp+hlt,(Cyclic code error)
	substat_entry	12,010101,rp+hlt,(Search error (not first search))
	substat_entry	12,010110,rp+hlt,(Sync byte not HEX19)
	substat_entry	12,010111,rp+hlt,(Error in alternate track)
	substat_entry	12,011001,rp,(EDAC correction - last sector)
	substat_entry	12,011010,rp,(EDAC corr. - not last sector)
	substat_entry	12,011011,rp,(EDAC corr. - block count limit)
	substat_entry	12,011100,rp,(Uncorrectable EDAC error)
	substat_entry	12,011101,rp,(EDAC corr. - short block)
	substat_entry	12,100001,rp+hlt,(Write buffer parity)
	substat_entry	12,100010,bk+rp,(Uncorrectable read)
" 

	status_entry	14,(MPC Command Reject)

	substat_entry	14,000001,rp+hlt,(Illegal procedure)
	substat_entry	14,000010,rp+hlt,(Illegal logical channel)
	substat_entry	14,000011,rp+hlt,(Illegal suspended logical chnnl)
	substat_entry	14,000100,rp+hlt,(Continue bit not set)




	end




		    exercise_disk.pl1               10/29/86  1036.8rew 10/28/86  1023.5      781533



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




/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-18,Coppola), install(86-07-18,MR12.0-1098):
     Support FIPS.
  2) change(86-01-16,Fawcett), approve(86-04-10,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Add support for 512_WORD_IO devices.
  3) change(86-06-04,Hartogs), approve(86-06-04,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Changed to use version constant in rcp_disk_info.incl.pl1
  4) change(86-10-21,Fawcett), approve(86-10-21,PBF7383),
     audit(86-10-23,Farley), install(86-10-28,MR12.0-1200):
     Change the d338 to 3380 and d339 to 3381.
                                                   END HISTORY COMMENTS */

exercise_disk: proc;


/* Written by B. Greenberg sometime in '75 */
/* Modified by P.B. Kelley 02/05/79 - to add the "-all" control argument.	  	*/
/*	The sector ranges were changed to NOT include those in the ALT partition,	*/
/*	unless the  "-all" control argument were given.				*/
/* Modified by Michael R. Jordan 1/80  to add -system (-sys) */


/* ********************************************************
   *    Completely re-written July 1980 by R.L. Coppola   *
   ******************************************************** */

/*  Modified 5/81 by Rich Coppola to remove PL1 I/O. */
/*  Modified 5/81 by Rich Coppola to add -no_write_compare (-nwc) */
/*  Modified 5/81 by Rich coppola to call analyze_detail_stat_ to have
   detailed status interpreted. */
/*  Modified Oct 1982 by Rich Coppola to change call to analyze_detail_stat_
   to use new calling sequence.
*/
/*  Modified 6/85 by Rich Fawcett
	   to use only 512_seeks for MSU3380s and MSU3381s and delete MSU0509 */
/* ****************************************************************************
   *   This test is intended to be an extension of the standard T&D's.	 *
   *   when they cannot reproduce a problem the FER should invoke this 	 *
   *   test to attempt to replicate the problem experienced by the customer.	 *
   *   This test uses the write and verify command to ensure that,
   *   as much as possible, all error conditions are captured.
   *
   **************************************************************************** */



/* Subroutine entry declarations */


	dcl     iox_$find_iocb	 entry (char (*), ptr, fixed bin (35));

	dcl     iox_$destroy_iocb	 entry (ptr, fixed bin (35));

	dcl     analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);

	dcl     analyze_detail_stat_$rsnnl entry (char (*), bit (36) aligned, bit (*) unal, char (*) var, bit (1), fixed bin (35));

	dcl     disk_status_table_$disk_status_table_ ext;

	dcl     clock_		 entry returns (fixed bin (52));

	dcl     command_query_	 entry options (variable);

	dcl     error_table_$badopt	 external fixed bin (35);

	dcl     error_table_$noarg	 external fixed bin (35);


	dcl     error_table_$device_parity fixed bin (35) ext static;

	dcl     com_err_		 entry options (variable);

	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35));

	dcl     cu_$arg_count	 entry () returns (fixed bin);

	dcl     date_time_		 entry (fixed bin (52), char (*));

	dcl     ioa_		 entry options (variable);

	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));

	dcl     error_table_$wrong_no_of_args fixed bin (35) ext static;


/* Automatic */

	dcl     dt		 char (24);
	dcl     code		 fixed bin (35);
	dcl     argptr		 ptr,		/* Pointers to input args  */
	        argcnt		 fixed bin,	/* number of args */
	        arglen		 fixed bin,	/* Lengths of input args  */
	        arg		 char (arglen) based (argptr),
	        arg_sw		 bit (1) init ("1"b);
	dcl     i			 fixed bin;	/* iteration var's */
	dcl     arg1		 char (8) varying;
	dcl     pack_id		 char (12);
	dcl     (from_sw, to_sw, dev_sw) bit (1) init ("0"b);
	dcl     (from, to_)		 fixed bin (24);
	dcl     dev_idx		 fixed bin;
	dcl     words_per_sector	 fixed bin init (64);
	dcl     (a, seek_counter)	 fixed bin;	/* counter) for the write read pass */
	dcl     (x, y, sectors_written, sectors_read, highest_sector, loest_sector) fixed bin (24);
	dcl     seek_addr_read	 fixed bin (24);
	dcl     to_sector		 fixed bin (24);
	dcl     device_type		 char (4);
	dcl     model_num		 fixed bin;

	dcl     1 my_key1,
		2 key1_len	 fixed bin init (8),
		2 f91		 pic "99999999";

	dcl     1 my_key2,
		2 key2_len	 fixed bin init (8),
		2 f92		 pic "99999999";

	dcl     key1		 char (256) var based (addr (my_key1));
	dcl     key2		 char (256) var based (addr (my_key2));
	dcl     (data_init_sw, compare_err) bit (1) init ("0"b);
	dcl     constant_		 bit (36) init ("0"b);
	dcl     doing		 char (5) var init ("");
	dcl     (cleanup, program_interrupt) condition;
	dcl     (ii, err_cnt)	 fixed bin init (0);
	dcl     system		 char (4) varying init ("");
	dcl     write_compare	 char (7) varying init ("wrtcmp");
	dcl     (rec_len, read_data_len) fixed bin (21);


	dcl     1 errors		 (50) aligned,
		2 iom_status_	 bit (72),
		2 det_status	 (11) bit (8) unal,
		2 dev_cmd_	 fixed bin,
		2 seek_addr_	 fixed bin (24);

	dcl     (quit_flag, ndc_sw, alt_sw) bit (1) init ("0"b);
	dcl     (random_sw, read_sw, write_sw) bit (1);	/* bit switches for program modes */
	dcl     (seq_sw, range_sw, dev_evn, dev_attached, dev_open) bit (1) init ("0"b);
	dcl     mode_string		 char (11);	/* string storage for ioa_ */
	dcl     (write_errors, read_errors, read_cmp_err, seek_errors) fixed bin;
	dcl     answer		 char (32) varying;
	dcl     (data_bufp, read_ptr, stat_tablep, iocbp, dev_infop, dev_statp, querie) ptr;
	dcl     (sa1, sn1, cn1, hn1, seek, seek1, seek2) fixed bin (24);
	dcl     (PC, PH, epc, opc)	 fixed bin (24);

	dcl     1 device_info	 aligned,		/* my dev info from exdim_ */
		2 dev_type_	 char (4),	/* the model number */
		2 dev_name	 char (8),	/* i.e. dskx_xx */
		2 sect_per_dev_	 fixed bin (35),
		2 cyl_per_dev_	 fixed bin,
		2 sect_per_cyl_	 fixed bin,
		2 sect_per_track_	 fixed bin,
		2 num_label_sect_	 fixed bin,
		2 num_alt_sect_	 fixed bin,
		2 sect_size_	 fixed bin (12);

	dcl     1 device_status_info	 aligned,		/* device status info */
		2 iom_status	 bit (72),
		2 detail_status	 (11) bit (8) unal,
		2 dev_cmd		 fixed bin,
		2 seek_addr	 fixed bin (24);

	dcl     device_name		 char (8);
	dcl     open_mode		 fixed bin init (13); /* assume write oper. */
	dcl     options_ptr		 ptr;
	dcl     1 options_,
		2 num_opts	 fixed bin,
		2 options		 (6) char (32) varying;


/* Static */

	dcl     myname		 char (13) init ("exercise_disk") static options (constant);
	dcl     str1		 bit (4) init ("1101"b) static options (constant);
	dcl     str2		 bit (4) init ("1011"b) static options (constant);
	dcl     str3		 bit (4) init ("0110"b) static options (constant);
	dcl     err_retry		 fixed bin static init (0);
	dcl     cmd_tbl		 (26:28) char (1) int static options (constant) init
				 ("R", "W", "S");
	dcl     TRUE		 bit (1) int static options (constant) init ("1"b);
	dcl     FALSE		 bit (1) int static options (constant) init ("0"b);
	dcl     test_in_progress	 fixed bin internal static;
	dcl     d500_sw		 bit (1) init ("0"b);


/* Based */

	dcl     data		 (0:(words_per_sector - 1)) bit (36) based (data_bufp) aligned;
	dcl     read_data		 (0:(words_per_sector - 1)) bit (36) based (read_ptr);

/* Builtins */

	dcl     (addr, addrel, bin, bit, ceil, char, clock, divide, fixed, floor, hbound, index, length, ltrim, max, min, mod, null, rel, rtrim, substr, unspec) builtin;


	if test_in_progress = -1 then do;
		call com_err_ (0, myname, "exercise_disk has been recursively invoked ");
		call com_err_ (0, myname, "enter the release (rl) command and re-call");
		return;
	     end;

/*                  Housekeeping                  */

	stat_tablep = addr (disk_status_table_$disk_status_table_);
	device_name = "";
	sectors_written, sectors_read, write_errors = 0;
	read_errors, seek_errors, read_cmp_err = 0;
	querie = addr (query_info);
	yes_or_no_sw = TRUE;
	repeat_time = 60;
	cp_escape_control = "11"b;			/* allow cp escape */
	suppress_name_sw = FALSE;
	constant_ = str1 || str2 || str3 || str1 || str2 || str3 || str1 || str2 || str3;
	data_bufp = null;
	read_ptr = null;
	from, to_, loest_sector = 0;


	on cleanup begin;
		call EXIT;
		test_in_progress = 0;
	     end;

	argcnt = cu_$arg_count ();

	if argcnt < 2 then do;
		arg_sw = "0"b;
		code = error_table_$wrong_no_of_args;
		go to bad_arg;
	     end;

	a = 1;					/* set to get first argument */
	call cu_$arg_ptr (a, argptr, arglen, code);
	if code ^= 0				/* No arg1  */
	then do;
		arg_sw = "0"b;
		go to bad_arg;			/* inform user on correct call */
	     end;

	arg1, device_type = arg;
						/*        Verify Device Type    */

	do i = 1 to maxdevt;
	     if device_type = device_names (i) then do;
		     model_num = MODELN (i);
		     if MODELN (i) >= 500 then
			d500_sw = "1"b;
		     dev_idx = i;
		end;
	end;



/*                            Get high sector no.                            */
	highest_sector = get_dev_size (code);
	if code ^= 0
	then go to bad_arg;				/* inform user on correct call */


/*                            Get pack Ser No. for Mount MSG.                */

	a = 2;					/* set up to get second argument */
	call cu_$arg_ptr (a, argptr, arglen, code);
	if code ^= 0
	then do;
		arg_sw = "0"b;
		go to bad_arg;			/* tell him how to invoke */
	     end;

	pack_id = rtrim (arg);
						/*                            See if there are anymore args                  */

	random_sw, write_sw, read_sw = TRUE;		/* set defaults */
	seq_sw, range_sw, ndc_sw, alt_sw = FALSE;	/* set defaults */
	from, to_ = 0;

	if argcnt > 2 then /* process control args if they exist */
	     do a = 3 to argcnt;

		arg_sw = "1"b;
		call cu_$arg_ptr (a, argptr, arglen, code);
		if code ^= 0
		then go to bad_arg;

		if arg = "-w" | arg = "-write" then do;
			read_sw = FALSE;		/* turn off read switch */
			write_sw = TRUE;		/* turn on write switch */

		     end;


		else if arg = "-r" | arg = "-read" then do;
			read_sw = TRUE;
			write_sw = FALSE;		/* turn off write switch */
			open_mode = 11;		/* set to read only */
		     end;




		else if arg = "-wr" | arg = "-write_read" then do; /* default but set them, anyway */
			read_sw = TRUE;
			write_sw = TRUE;

		     end;

		else if arg = "-device" |
		     arg = "-dv" then do;		/* he wants to select a specific  drive */
			a = a + 1;		/* bump arg ptr */
			call cu_$arg_ptr (a, argptr, arglen, code);

			if code ^= 0 then
			     go to bad_arg;

			if (arglen ^= 7) | (substr (arg, 1, 3) ^= "dsk") then do;
				a = a - 1;
				go to bad_arg;
			     end;

			else device_name = arg;
			dev_sw = "1"b;
		     end;


		else if arg = "-ndc" | arg = "-no_data_compare" then
		     ndc_sw = TRUE;			/* Turn off data compare on read  */

		else if arg = "-alternate_track" | arg = "-altrk" then /* pack formatted with alt tracks */
		     alt_sw = TRUE;


		else if arg = "-random" then /* random option */
		     random_sw = TRUE;


		else if arg = "-sequential" | arg = "-sq" then do; /* sequential seek option */
			random_sw = FALSE;
			seq_sw = TRUE;
		     end;

		else if arg = "-from" | arg = "-fm" then do;
			range_sw = TRUE;
			random_sw = FALSE;
			a = a + 1;
			call cu_$arg_ptr (a, argptr, arglen, code);

			if code ^= 0 then
			     go to bad_arg;

			if index (arg, "-") ^= 0
			then go to bad_arg;

			from = cv_dec_check_ (arg, code);

			if code ^= 0 then
			     go to bad_arg;

			loest_sector = get_seek_addr (from, code);
			if code ^= 0 then
			     go to bad_arg;

			from_sw = TRUE;
		     end;

		else if arg = "-to" then do;

			range_sw = TRUE;
			a = a + 1;
			call cu_$arg_ptr (a, argptr, arglen, code);

			if code ^= 0 then
			     go to bad_arg;

			if index (arg, "-") ^= 0
			then go to bad_arg;

			to_ = cv_dec_check_ (arg, code);

			if code ^= 0 then
			     go to bad_arg;

			to_sector = get_seek_addr (to_, code);
			if code ^= 0 then
			     go to bad_arg;

			to_sw = TRUE;
		     end;

		else if arg = "-system" | arg = "-sys"
		then system = "-sys";

		else if arg = "-no_write_compare" | arg = "-nwc" then
		     write_compare = "^wrtcmp";


		else do;				/* unrecognizable arg */
bad_arg:

			if arg_sw = "1"b then do;
				code = error_table_$badopt;
				call com_err_ (code, myname, "Invalid or unrecognizable control arg in string (^a).", arg);
			     end;
			else do;
				code = error_table_$noarg;
				call com_err_ (code, myname, "Number of args received insufficient.");
			     end;
			call ioa_ ("^a: Usage: exercise_disk DEVICE_TYPE PACK_ID {-control_args}", myname);
			return;
		     end;
	     end;


done_args:


	if MODELN (dev_idx) > 451 then /* all 5xx have alt tracks */
	     alt_sw = "1"b;


	call ioa_ ("^/^a: Device type is ^a pack serial no. is ^a", myname, arg1, pack_id);
	if write_sw then do;			/* ask only if writing */
		call ioa_ ("^a: exercise_disk will destroy all data on this pack ! ", myname);
		call command_query_ (querie, answer, myname, "Do You Wish To Continue?");
		if answer ^= "yes" then
		     return;
	     end;
start:

	options_.num_opts = 2;
	options_.options (*) = "";			/* init options */
	options_.options (1) = arg1;			/* now fill 'em in */
	options_.options (2) = pack_id;

	if dev_sw then do;
		options_.num_opts = options_.num_opts + 2;
		options_.options (options_.num_opts - 1) = "-dv";
		options_.options (options_.num_opts) = device_name;
	     end;
	if write_sw then do;
		options_.num_opts = options_.num_opts + 1;
		options_.options (options_.num_opts) = "-write";
	     end;
	if system = "-sys" then do;
		options_.num_opts = options_.num_opts + 1;
		options_.options (options_.num_opts) = system;
	     end;


	call ioa_ ("^a: Requesting mount of volume ^a^[ on ^a^].", myname, pack_id, dev_sw, device_name);

	iocbp = null;

	call iox_$find_iocb ("exercise_disk", iocbp, code);
	if code ^= 0 then do;
		call com_err_ (code, myname, "Finding IOCB.");
		return;
	     end;

	test_in_progress = -1;			/* we have really started */

	options_ptr = addr (options_);
	call exdim_attach (iocbp, options_ptr, "0"b, code);

	if code ^= 0 then do;
		call com_err_ (code, "exercise_disk", "Attaching I/O disk.");
		go to llose;
	     end;

	dev_attached = "1"b;

	call exdim_open (iocbp, open_mode, code);
	if code ^= 0 then do;
		call com_err_ (code, myname, "Setting opening mode ^a", open_mode);
		go to llose;
	     end;

	dev_open = "1"b;

	if alt_sw then do;				/* Alt track setup */
		call exdim_modes (iocbp, "^label,alttrk," || write_compare, code);
		if code ^= 0 then do;
			call com_err_ (code, myname, "Setting modes (altrk).");
			go to llose;
		     end;

		highest_sector = last_sect_num (dev_idx);
	     end;



	else do;					/* No ^alt. trk format */
		call exdim_modes (iocbp, "^label," || write_compare, code);
		if code ^= 0 then do;
			call com_err_ (code, myname, "Setting modes.");
		     end;
	     end;

	words_per_sector = words_per_sect (dev_idx);


	if write_sw then /* option w or wr */
	     allocate data set (data_bufp);

	if read_sw then do;
		allocate read_data set (read_ptr);	/* option wr or r */
		if ^write_sw then
		     if ^ndc_sw then
			allocate data set (data_bufp);/* option r */
	     end;

	if random_sw				/* fill in string for startup message */
	then mode_string = "random";

	else if seq_sw
	then mode_string = "sequential";

	else mode_string = "range";

	dev_infop = addr (device_info);
	call exdim_control (iocbp, "device_info", dev_infop, code);
	device_name = dev_name;

	if mod (bin (substr (device_name, 6, 2)), 2) = 0 then
	     dev_evn = "1"b;

	else dev_evn = "0"b;

	rec_len, read_data_len = 4 * sect_size_;	/* num chars in a sector */

	call date_time_ (clock_ (), dt);
	call ioa_ ("^/^a: Begin ^a test on ^a (^a) @  ^a", myname, mode_string, dev_name, dev_type_, substr (dt, 11, 6));

	on program_interrupt begin;
		call convert_seek_addr (seek, sa1, sn1, cn1, hn1); /* get cyl and head info */
		call ioa_ ("^a:^2xCurrently at cyl ^d head ^d", myname, cn1, hn1);
		call ioa_ ("^a:^2xsectors read^10d; sectors written^10d.", myname, sectors_read, sectors_written);
	     end;

	if random_sw				/* check random versus sequential */
	then do;					/* random test */
		seek_counter = 0;
		do while (seek_counter < 10000000);	/* a nominal number */
start_rand:	     x = mod (clock (), highest_sector);/* generate one seek address */
		     y = highest_sector - x;		/* and its converse */
		     err_retry = 0;			/* zero on successful io */
random_write:	     if write_sw then do;		/* first do the write of two sectors */
			     seek1 = x;
			     seek2 = y;
			     call write_sector;
			     seek_counter = seek_counter + 2; /* bump counter */
			end;			/* end of write of two sectors */

		     if read_sw then do;		/* do read of two sectors */
			     seek1 = x;
rand_read:		     call read_sector;
			     seek1 = y;
			     call read_sector;
			     seek_counter = seek_counter + 2; /* bump counter by number of reads */
			end;			/* end of read of two sectors */
		end;				/* seek_counter now max */
	     end;					/* end of a random pass */

	else if seq_sw then
	     do x = 0 to (highest_sector - 1) by 2;	/* walk through sequentially */
start_seq:	y = x + 1;
		err_retry = 0;			/* zero on successful io */
seq_write:	if write_sw then do;		/* write two sectors */
			seek1 = x;
			seek2 = y;
			call write_sector;
		     end;				/* end of writing two */

		if read_sw then do;			/* read two sectors */
			seek1 = x;
seq_read:			call read_sector;
			seek1 = y;
			call read_sector;
		     end;				/* end of read of two sectors */
	     end;					/* end of a sequential pass */


	else do;					/* Must be a range */

start_range:	x = loest_sector;			/* Beginning seek addr */
		y = to_sector;
range_cont:	err_retry = 0;

range_write:	if write_sw then do;
			seek1 = x;
			seek2 = y;
			call write_sector;
		     end;

range_read:	if read_sw then do;
			seek1 = x;
			call read_sector;
			seek1 = y;
			call read_sector;
		     end;

		err_retry = 0;

		x = x + 1;
		y = y - 1;


		if x = to_sector then
		     go to start_range;

		else go to range_write;
	     end;

llose:
	call EXIT;
	return;


error1:

	err_retry = err_retry + 1;
	call error;

	if quit_flag then /* time to go home */
	     go to llose;

	if err_retry = 5 then do;			/* have reached the limit */
		err_retry = 0;
		call command_query_ (querie, answer, myname, "Unrecoverable disk error.  Do you wish to continue?");
		if answer ^= "yes" then do;
			go to llose;
		     end;


		if random_sw then go to start_rand;

		else if seq_sw then go to start_seq;
		else go to range_write;
	     end;

	if random_sw & ^compare_err then
	     go to random_write;			/* go retry */

	if random_sw & compare_err then
	     go to rand_read;			/* see if we can read and display the mis-compare */

	if seq_sw & ^compare_err then
	     go to seq_write;

	if seq_sw & compare_err then
	     go to seq_read;

	if range_sw & ^compare_err then
	     go to range_write;

	if range_sw & compare_err then
	     go to range_read;

	else go to llose;				/* must be lost */


%page;

write_sector: proc;

/* ************************************************************************
   *   this routine is used to issue the write and read and compare the    *
   *   data read from the read command			       *
   ************************************************************************ */

	dcl     (data_was, data_sb)	 bit (36 * words_per_sector) based;
	dcl     (seek_addr, sect_no, cylno, hdno) fixed bin (24);
	dcl     z			 fixed bin;



	f91 = seek1;
	f92 = seek2;
	seek = seek1;
	call build_sb;				/* build the data buffer */
	call exdim_seek (iocbp, key1, rec_len, code);

	if code ^= 0 then do;
		call com_err_ (code, myname, "Attempt to use an invalid seek key (^a).", f91);
		go to llose;
	     end;


	call exdim_rewrite (iocbp, data_bufp, rec_len, code);

	if code ^= 0 then do;
		if code ^= error_table_$device_parity then do; /* my prob */
			call com_err_ (code, myname, "Performing rewrite operation.");
			go to llose;
		     end;

		else go to error1;
	     end;

	seek = seek2;
	call build_sb;				/* build the data buffer */
	call exdim_seek (iocbp, key2, rec_len, code);

	if code ^= 0 then do;
		call com_err_ (code, myname, "Attempt to use an invalid seek key (^a).", f92);
		go to llose;
	     end;


	call exdim_rewrite (iocbp, data_bufp, rec_len, code);

	if code ^= 0 then do;
		if code ^= error_table_$device_parity then do; /* my prob */
			call com_err_ (code, myname, "Performing rewrite operation.");
			go to llose;
		     end;

		else go to error1;
	     end;

	sectors_written = sectors_written + 2;		/* keeep track of what weve done */

	return;

read_sector: entry;
	seek, f91 = seek1;
	if ndc_sw then ;				/* do nothing if not checking data */

	else do;					/* user requested data compare */
		call build_sb;			/* so generate a "should be" image */
		read_ptr -> data_was = FALSE;		/* zap the read buffer */
	     end;					/* finished preparingg for data compare */


	call exdim_seek (iocbp, key1, rec_len, code);

	if code ^= 0 then do;
		call com_err_ (code, myname, "Attempt to use an invalid seek key (^a).", f91);
		go to llose;
	     end;


	call exdim_read (iocbp, read_ptr, read_data_len, rec_len, code);

	if code ^= 0 then do;
		if code ^= error_table_$device_parity then do; /* my prob */
			call com_err_ (code, myname, "Performing read operation.");
			go to llose;
		     end;

		else go to error1;
	     end;

	sectors_read = sectors_read + 1;		/* keep track of what weve done */
	if ndc_sw					/* check not data compare switch */
	then ;					/* no data compare wanted */

	else do;					/* now check the read versus the should be */
		if read_ptr -> data_was = data_bufp -> data_sb /* fast compare on entire sector */
		then ;				/* they are equal...all is well */

		else do z = 0 to (words_per_sector - 1);/* fast compare failed so walk and find first error */
			if data (z) ^= read_data (z) then do;
				call ioa_ ("^/^a data compare error at address ^d, word ^d", myname, seek, z);
				call convert_seek_addr (seek, seek_addr, sect_no, cylno, hdno);
				if z = 0 then do;	/* error in seek addr */
					seek_addr_read = bin (substr (read_data (0), 13, 24), 24);
					call ioa_ ("Word in error is the seek address.");
					call ioa_ ("Word 0 should be: ^d (cyl ^4d, head ^3d, sector ^4d).",
					     seek, cylno, hdno, sect_no);

					call convert_seek_addr (seek_addr_read, seek_addr, sect_no, cylno, hdno);
					call ioa_ ("Word 0 was      : ^d (cyl ^4d, head ^3d, sector ^4d).",
					     seek_addr_read, cylno, hdno, sect_no);
					read_cmp_err = read_cmp_err + 1;
					return;
				     end;


				call ioa_ ("^9x Seek Address^2x^d^2xSector^2x^d^2xCyl^2x^d^2xHead^2x^d",
				     seek_addr, sect_no, cylno, hdno);

				call ioa_ ("^/^9xWord ^d^5xWord ^d^5xWord ^d^5xWord ^d", z, z + 1, z + 2, z + 3);
				call ioa_ ("^2xis:^3x^.4b^2x^.4b^2x^.4b^2x^.4b", read_data (z), read_data (z + 1), read_data (z + 2), read_data (z + 3));

				call ioa_ ("^xs/b:^3x^.4b^2x^.4b^2x^.4b^2x^.4b", data (z), data (z + 1), data (z + 2), data (z + 3));
				read_cmp_err = read_cmp_err + 1;
				return;
			     end;
		     end;
	     end;

	return;
     end write_sector;

%page;
build_sb: proc;					/*  build up the should be buffer for the read compare */

	dcl     i			 fixed bin;

	data (0) = bit (0, 12) || bit (seek, 24);	/* put in seek address */
	do i = 1 to words_per_sector - 1;
	     data (i) = constant_;
	end;

	return;
     end build_sb;

%page;
error: proc;


/* ************************************************************************
   *   this routine displays the error data to the user and stores the     *
   *   error info away for test summarization. On an attention condition   *
   *   it will ask the user whether or not he wishes to continue.          *
   ************************************************************************ */

	dcl     (s_a, se_n, cyl_no, hd_no) fixed bin (24);
	dcl     my_analyses		 (20) char (40) varying;

	dcl     detailed_status	 bit (88) unal based (addr (detail_status));
	dcl     msg		 char (256) var init ("");
	dcl     is_interesting	 bit (1);
	dcl     DATA_ALRT_CMPRR	 bit (10) int static options (constant) init (
				 "0011100000"b);	/* Data Alert, Compare Error */
	dcl     ATTN		 bit (4) int static options (constant) init (
				 "0010"b);	/* Attention Condition major status */

	is_interesting = "0"b;
	compare_err = FALSE;
	my_analyses (*) = "";
	dev_statp = addr (device_status_info);
	call exdim_control (iocbp, "hardware_status", dev_statp, code); /* get the status */

	if dev_cmd = 27 then do;
		doing = "write";
		write_errors = write_errors + 1;
	     end;

	else if dev_cmd = 21 then do;
		doing = "read";
		read_errors = read_errors + 1;
		dev_cmd = dev_cmd + 5;
	     end;

	else if dev_cmd = 28 then do;
		doing = "seek";
		seek_errors = seek_errors + 1;
	     end;

	if substr (iom_status, 3, 10) = DATA_ALRT_CMPRR then
	     compare_err = TRUE;

	if err_cnt < 50 then do;
		err_cnt = err_cnt + 1;

		device_status_info.seek_addr = seek;
		errors (err_cnt) = device_status_info;	/* save this for later analysis */
	     end;

	else do;
		call ioa_ ("^/^a: Too many errors encountered in test!^/^15xFix disk drive (^a) and re-run.", myname, device_name);
		quit_flag = TRUE;
	     end;

	call convert_seek_addr (seek, s_a, se_n, cyl_no, hd_no);

	call analyze_device_stat_$rsnnl (msg, stat_tablep, (iom_status), ("0"b));
	call date_time_ (clock_ (), dt);

	call ioa_ ("^/^a: ^a error on ^a @ ^a;",
	     myname, doing, device_name, substr (dt, 11, 6));

	call ioa_ ("^15xSeek Addr ^o, ^[Logical ^]cyl ^d hd ^d^[, Physical cyl ^d hd ^d^]",
	     seek, d500_sw, cyl_no, hd_no, d500_sw, PC, PH);


	call ioa_ ("^15x^a (^2o/^2o)", msg, substr (iom_status, 3, 4),
	     substr (iom_status, 7, 6));

	if detail_status (1) then do;
		msg = "";
		call analyze_detail_stat_$rsnnl (device_name, substr (iom_status, 1, 36),
		     detailed_status, msg, is_interesting, code);
		if msg ^= "" then
		     call ioa_ ("^15xDetailed Status: ^a", msg);
	     end;


	if quit_flag then return;

	if substr (iom_status, 3, 4) = ATTN then do;	/* is it an attention cond? */
		call command_query_ (querie, answer, myname,
		     "Your disk drive (^a) requires attention.^/^-^5xPlease check it out or have the operator do so
^-^5xand reply appropriately AFTER the device has been checked.

^-^5xDo you wish to retry?", device_name);

		if answer ^= "yes" then
		     quit_flag = TRUE;

	     end;



	return;
     end error;
%page;

get_dev_size: proc (acode) returns (fixed bin (24));

/* **********************************************************************
   *   Returns the highest sector address for the specified device type   *
   ********************************************************************** */

	dcl     acode		 fixed bin (35);
	dcl     dvt		 fixed bin;

	acode = 0;
	do dvt = 1 to maxdevt;
	     if device_type = device_names (dvt) then do;
		     acode = 0;
		     return (last_alt_sect_num (dvt));
		end;
	end;
	acode = 1;
	return (0);


     end;
%page;

convert_seek_addr: proc (sector, sa, se_no, cyl_, hd_);

/* **********************************************************************
   *   given a seek address, this routine returns the sector, head and   *
   *   cylinder information from that address			     *
   ********************************************************************** */

	dcl     ecode		 fixed bin (35);
	dcl     (sector, se_no, sa, cyl_, hd_) fixed bin (24);


	sa = divide (sector, sect_per_track (dev_idx), 24, 0);
	se_no = mod (sector, sect_per_track (dev_idx));
	cyl_ = divide (sa, tracks_per_cyl (dev_idx), 24, 0);
	hd_ = mod (sa, tracks_per_cyl (dev_idx));

	if model_num >= 500 then do;
		if mod (cyl_, 2) = 0 then do;
			epc = cyl_ + 1;
			opc = cyl_;
			PH = hd_ * 2;
		     end;

		else do;
			epc = cyl_;
			opc = cyl_ - 1;
			PH = (hd_ * 2) + 1;
		     end;
		if dev_evn then
		     PC = epc;
		else PC = opc;

	     end;


	return;


get_seek_addr: entry (sector, ecode) returns (fixed bin (24));


/* This routine returns a seek address from the user supplied
   * starting/ending  cylinder number (from/to N) */


	ecode = 0;
	if alt_sw then /* check that the cyl input is not > largest cyl allowed */
	     if (sector * sect_per_cyl (dev_idx)) >
		last_sect_num (dev_idx) then do;
bad_ret:		     ecode = 1;
		     return (0);
		end;

	if ^alt_sw then
	     if (sector * sect_per_cyl (dev_idx)) >
		last_alt_sect_num (dev_idx) then
		go to bad_ret;

	return (sector * sect_per_cyl (dev_idx));

     end convert_seek_addr;
%page;
EXIT: proc;

	dcl     (sect_addr, sect, cyl, hd) fixed bin (24);
	dcl     temp_		 (err_cnt + 1) char (100) var init ((err_cnt + 1) (""));
	dcl     temp_str		 char (100) var init ("");
	dcl     (i, j, count_)	 fixed bin;
	dcl     (CA, PORT)		 char (10) var;
	dcl     ioa_$rsnnl		 entry () options (variable);
	dcl     linelth		 fixed bin;

	if test_in_progress = 0 then /* haven't really started */
	     return;

	if dev_open then do;
		call exdim_close (iocbp, code);
		dev_open = "0"b;
	     end;

	if dev_attached then do;
		call exdim_detach (iocbp, code);
		if code ^= 0 then
		     call com_err_ (code, myname, "Problems detaching, suggest a ""new_proc""");
		dev_attached = "0"b;
	     end;
	if data_bufp ^= null then
	     free data;				/* clean up if used */
	if read_ptr ^= null then /* ditto */
	     free read_data;

	if iocbp ^= null then
	     call iox_$destroy_iocb (iocbp, code);

	test_in_progress = 0;			/* truly I am dead */

	if sectors_written + sectors_read + err_cnt + read_cmp_err > 0 then do;

		call ioa_ ("^/^a: Testing Completed for ^a (^a).", myname, device_name, device_type);
		call ioa_ ("Test Summary:");
		call ioa_ ("Number of Sectors Written   ^12d", sectors_written);
		call ioa_ ("Number of Sectors Read^6x^12d", sectors_read);

		if err_cnt + read_cmp_err > 0 then do;

			call ioa_ ("Number of Write  I/O errors^7x ^5d", write_errors);
			call ioa_ ("Number of Read   I/O errors^7x ^5d", read_errors);
			call ioa_ ("Number of Read Compare Errors^6x^5d", read_cmp_err);
			if err_cnt < 1 then return;


			call ioa_ ("^/Error Location Summary:^/^/^xError Count^4xCylinder^2xHead^3xR/W^2xCA^2xPort^[ Physical  CYL/HD^]", d500_sw);
			call ioa_ ("^x===========^4x========^2x====^3x===^2x==^2x====^[ ================^]", d500_sw);

			do ii = 1 to err_cnt;
			     if errors (ii).det_status (1) then do;
				     CA = ltrim (rtrim (char (fixed (substr (errors (ii).det_status (10), 8, 1), 1))));
				     PORT = ltrim (rtrim (char (fixed (substr (errors (ii).det_status (11), 4, 5), 5))));
				end;
			     else do;
				     CA = " ";
				     PORT = "     ";
				end;

			     if length (PORT) = 1 then
				PORT = "    " || PORT;
			     else if length (PORT) = 2 then
				PORT = "   " || PORT;

			     call convert_seek_addr (errors (ii).seek_addr_, sect_addr, sect, cyl, hd);
			     call ioa_$rsnnl ("^12d^2x^4d^4x^1a^4x^1a^x^5a^[^46t^3d/^2d^]",
				temp_ (ii), linelth, cyl, hd,
				cmd_tbl (errors (ii).dev_cmd_),
				CA, PORT, d500_sw, PC, PH);


			end;

			do i = 1 to err_cnt - 1;	/* sort the errors */
			     do j = (i + 1) to err_cnt;
				if temp_ (i) > temp_ (j) then do;
					temp_str = temp_ (i);
					temp_ (i) = temp_ (j);
					temp_ (j) = temp_str;
				     end;
			     end;
			end;

			count_, x = 1;

print_it:			do i = x to err_cnt;
			     do j = (i + 1) to err_cnt + 1;
				if temp_ (i) = temp_ (j) then
				     count_ = count_ + 1;
				else do;
					call ioa_ ("^7x^5d^a", count_, temp_ (i));
					x = j;
					count_ = 1; /* reset the counter */
					go to print_it;
				     end;
			     end;
			end;

			call ioa_ ("^/^/");
		     end;


		else call ioa_ ("^/^a: No errors encountered in test.", myname);
	     end;

	return;
     end EXIT;
%page;


/* This subroutine is a modified version of rdisk_. It has been modisfied to
   * support exercise_disk in a streamline fashion, with a much improved
   * error handling capability. */


exdim_: proc;
	return;					/* do not enter here */


	dcl     1 disk_data		 based (disk_ptr),	/*  exdim_ data structure  */
		2 attach_descrip	 aligned,		/*  Current attach description  */
		  3 length	 fixed bin (17),	/*  Length of description in chars.  */
		  3 descrip	 char (168),	/* the actual description  */
		2 attach_data	 aligned,		/*  attachment data for use by  exdim_  */
		  3 sze		 fixed bin (35),	/* if ^= 0 => size specified in attach or control  */
		  (3 err_sw,			/* on if error messages are to be printed  */
		  3 write_sw,			/*  on if  device is to be mounted in write mode  */
		  3 compare_sw,			/*   on if Write_and_Compare idcw is to be used for writes  */
		  3 raw_sw,			/* ON => raw mode */
		  3 alt_sw,			/* ON => alt mode */
		  3 label_sw,			/* ON => label mode */
		  3 sys_sw)	 bit (1) unal,	/*  on if this is a privileged system process  */
		  3 pack_id	 char (32),	/*  Current disk pack id.  */
		  3 rcp_id	 bit (36),	/* rcp unique id. */
		  3 max_buff_size	 fixed bin (19),	/* ioi_ buffer size limit set by rcp_ */
		  3 wait_list,			/*  event channel information  */
		    4 nchan	 fixed bin,	/* number of channels (currently using 1)  */
		    4 ev_chan	 fixed bin (71),	/* event channel id.  */
		  3 dev_type	 fixed bin,	/*  device type indicator   */
		  3 devx		 fixed bin,	/* device index returned by ioi_ */
		  3 drive		 fixed bin (6),	/* drive number returned by ioi_ */
		  3 errors	 fixed bin,	/* error count */
		  3 sect_per_dev	 fixed bin (35),	/* sectors per device */
		  3 sect_size	 fixed bin (12),	/* quantity of words in one sector */
		  3 num_alt_sect	 fixed bin,	/* quantity of sectors reserved for alternate sector usage */
		  3 device_group	 fixed bin,	/* 1 = MSU04XX */
						/* 2 = MSU0500/1 */
						/* 3 = MSU3380 & MSU3381 */
		2 open_descrip	 aligned,		/* open description */
		  3 length	 fixed bin (17),	/* number of characters in open descrip. */
		  3 descrip	 char (32),	/* the actual open descrip. */
		2 open_data	 aligned,		/* more exdim_ data */
		  3 mode		 fixed bin,	/* mode number:  4 = sq_i, 5 = sq_o, 7 = sq_u,
						   11 = d_i, 13 = d_u    */
		  3 buf_ptr	 ptr,		/* pointer to buffer created by ioi_$workspace */
		  3 fill		 bit (9),		/* Fill left-over part of last sector of the current record with this value when writing. */
		  3 buf_len	 fixed bin (19),	/*  length (words) of buffer */
		  3 data_len	 fixed bin (19),	/* length of data area in buffer */
		  3 time_int	 fixed bin (52),	/* current time out interval */
		  3 next_key	 fixed bin (35),	/* next key as per iox_ */
		  3 current_key	 fixed bin (35),	/* current key as per iox_ */
		  3 key_for_insertion fixed bin (35),	/* key for insertion as per iox_  */
						/* key_for_insertion is always null for the
						   present implementation, since write_record
						   is not supported for direct_update.  */
		  3 bounds,			/* current key  boundaries */
		    4 low		 fixed bin (35),	/* the lower bound */
		    4 high	 fixed bin (35),	/* higher bound */
		  3 mode_string	 char (32) varying, /* current modes */
		  3 rcp_data	 (size (disk_info)) fixed bin (35); /* area for rcp_disk_info structure */

	dcl     1 status		 based (addr (iom_stat)), /* breakout of iom_stat */
		2 pad		 bit (2) unal,	/* not used */
		2 maj		 bit (4) unal,	/* major status */
		2 sub		 bit (6) unal,	/* sub status */
		2 pad2		 bit (48) unal,	/* not used */
		2 residue		 bit (12) unal;	/* tally residue */

	dcl     1 seek		 aligned,
		2 block_count_limit	 fixed bin (12) unsigned unal,
		2 ti		 bit (2) unal,
		2 mbz		 bit (1) unal,
		2 sector		 fixed bin (21) unsigned unal;

	dcl     1 super_seek	 aligned,
		2 sector_number	 fixed bin (8) unsigned unal,
		2 mbz1		 bit (4) unal,
		2 ti		 bit (2) unal,
		2 is_super_seek	 bit (1) unal,
		2 flag		 bit (1) unal,
		2 mbz2		 bit (4) unal,
		2 cyl_lower	 fixed bin (8) unsigned unal,
		2 cyl_upper	 fixed bin (2) unsigned unal,
		2 head		 fixed bin (6) unsigned unal;

	dcl     1 buffer		 based (buf_ptr),	/* ioi_ buffer */
		2 control_info,			/* device control data */
		  3 (rst_idcw, sk_idcw, sk_dcw, rw_idcw, rw_dcw) fixed bin (35), /* DCW's */
		  3 seek_data	 like seek,	/* Information for seek DCW */
		  3 rsr_data	 bit (88) unal,	/* detailed device status read by RSR */
		  3 reserved	 (5) fixed bin (35),/* pad for future expansion */
		  3 istat		 aligned,		/* I/O Interfacer status structure */
		    4 completion,			/* completion flags */
		    ( 5 st	 bit (1),		/* "1"b if status returned */
		      5 er	 bit (1),		/* "1"b if status indicates error condition */
		      5 run	 bit (1),		/* "1"b if channel still running */
		      5 time_out	 bit (1)) unal,	/* "1"b if time-out occurred */
		    4 level	 fixed bin (3),	/* IOM interrupt level */
		    4 offset	 fixed bin (18),	/* DCW list offset */
		    4 absaddr	 fixed bin (24),	/* absolute address of workspace */
		    4 iom_stat	 bit (72),	/* IOM status */
		    4 lpw		 bit (72),	/* LPW residue */
		2 data		 char (4 * data_len); /* data area  */

	dcl     1 event_info	 aligned,		/*  event message info  */
		2 chan_id		 fixed bin (71),
		2 message,
		  3 pad1		 bit (15) unal,
		  3 int_level	 bit (3) unal,
		  3 pad2		 bit (36) unal,
		  3 special_type	 fixed bin (17) unal,
		2 sender		 bit (36),
		2 origin,
		  3 dev_signal	 bit (18) unal,
		  3 ring		 bit (18) unal,
		2 chan_x		 fixed bin;

	dcl     1 tp_info,				/*  terminate_process_ information */
		2 version		 fixed bin,	/* version no. (currently 0) */
		2 code		 fixed bin (35);	/* error code to be printed before process is termed */

	dcl     (disk_ptr, iocb_ptr, real_iocb_ptr, ubuf_ptr, block_ptr, rs_ptr, info_ptr, fmdp) ptr init (null); /* pointers */
	dcl     dcw_offset		 fixed bin (18);	/* offset in ioi_ buffer to first IDCW */
	dcl     (code, rec_len, data_left, mode_len, mode_start) fixed bin (35);
	dcl     key		 fixed bin (21);	/* working seek key */
	dcl     track_indicators	 bit (2) init ("00"b); /* track indicator bits for seek cmd */
	dcl     (count_limit_fixed, block_len) fixed bin (12);
	dcl     (i, num_opts, err_ct, rcp_state) fixed bin;
	dcl     (cyl, head)		 fixed bin (16);
	dcl     (again, not_sw, mode_err_sw) bit (1) unal;

	dcl     block		 char (4 * block_len) based (block_ptr); /*  current user data block */
	dcl     dev_id		 char (4);	/* alpha device id, e.g. D191 */
	dcl     rs_mode		 fixed bin (5);	/* rcp_sys_ access mode for this process */

	dcl     1 user_bounds	 based (info_ptr),	/* current bounds returned via this structure */
		2 low		 fixed bin (35),
		2 high		 fixed bin (35);

	dcl     new_modes		 char (24);	/* new modes for  modes oper. */
	dcl     next_mode		 char (8) varying init ("dummy");
	dcl     mask_str		 bit (36) aligned;	/* ips_ mask */
	dcl     1 mask		 based (addr (mask_str)), /* different def'n of above */
		2 pad		 bit (35) unal,	/* we don't use this */
		2 masked		 bit (1) unal;	/* flag to indicate if we are masked */
	dcl     temp_key		 fixed bin (35);
	dcl     1 drive_number,
		2 sign		 char (1),
		2 number		 char (2);
	dcl     drive_dec		 dec (2) based (addr (drive_number)); /* used for drive number conversion */
	dcl     drive_name		 char (8);	/* name of the requested device or spaces */
	dcl     model_number	 fixed bin;	/* model number requested by user */


/*	The following internal static items should all become constants when exdim_ is compiled.  */


	dcl     DEVICE_GROUP	 (9) fixed bin int static init (0, 2, 1, 1, 1, 1, 2, 3, 3);
						/* "bulk", "d500", "d451", "d400", "d190", "d181", "d501", "3380" "3381" */
	dcl     MSU04XX		 fixed bin int static init (1);
	dcl     overhead		 fixed bin int static init (24); /* number of control words reserved in ioi_ buffer */
	dcl     max_retries		 int static fixed bin init (110); /* number of times we will retry certain operations */
	dcl     ATTENTION		 int static bit (4) init ("0010"b);
	dcl     EOF		 int static bit (4) init ("0100"b);
	dcl     LAST_BLOCK		 int static bit (6) init ("000001"b);
	dcl     LAST_BLOCK_MASK	 int static bit (6) init ("111101"b);
	dcl     EXEC		 bit (5) int static init ("00100"b);
	dcl     STANDBY		 int static bit (6) init ("010000"b);
	dcl     INHIB_AUTO_RETRY	 bit (6) int static init ("010001"b);
	dcl     SPECIAL_SEEK	 bit (6) int static init ("011110"b);
	dcl     SEEK_512		 bit (6) int static init ("30"b3);
	dcl     SPECIAL_SEEK_512	 bit (6) int static init ("35"b3);
	dcl     LONG_WAIT		 fixed bin int static init (2);
	dcl     COMPLETE		 fixed bin int static init (0);
	dcl     DEFAULT		 bit (1) int static init ("0"b);
	dcl     NOT_SET		 fixed bin (6) int static init (-1);
	dcl     num_label_sect	 fixed bin int static init (8);
	dcl     rcp_dev_type	 char (32) int static init ("disk_drive");

/*	This is the end of the set of internal static items which should all become constants during compilation. */



	dcl     standby_idcw_string	 int static bit (36) init ("720000720201"b3);
	dcl     restore_idcw_string	 int static bit (36) init ("420000720201"b3);
	dcl     seek_idcw_string	 int static bit (36) init ("340000720000"b3);
	dcl     seek_dcw_string	 int static bit (36) init ("000000000001"b3);
	dcl     read_idcw_string	 int static bit (36) init ("250000700000"b3);
	dcl     write_idcw_string	 int static bit (36) init ("310000700000"b3);
	dcl     write_and_compare_idcw_string int static bit (36) init ("330000700000"b3);
	dcl     read_write_dcw_string	 int static bit (36) init ("000000000000"b3);

	dcl     1 standby_idcw_template defined (standby_idcw_string) like idcw;
	dcl     1 restore_idcw_template defined (restore_idcw_string) like idcw;
	dcl     1 seek_idcw_template	 defined (seek_idcw_string) like idcw;
	dcl     1 seek_dcw_template	 defined (seek_dcw_string) like dcw;
	dcl     1 read_idcw_template	 defined (read_idcw_string) like idcw;
	dcl     1 write_and_compare_idcw_template defined (write_and_compare_idcw_string) like idcw;
	dcl     1 write_idcw_template	 defined (write_idcw_string) like idcw;
	dcl     1 read_write_dcw_template defined (read_write_dcw_string) like dcw;

	dcl     (

	        error_table_$action_not_performed,	/*  notacted, The requested action was not performed.;  */
	        error_table_$bad_arg,			/*  bad_arg , Illegal command or subroutine argument.;  */
	        error_table_$bad_mode,		/*  badmode , Improper mode specification for this device.;  */
	        error_table_$device_end,		/*  devend  , Physical end of device encountered.;  */
	        error_table_$device_parity,		/*  xmiterr , Unrecoverable data-transmission error on physical device.;  */
	        error_table_$incompatible_attach,	/*  att^=opn, Attach and open are incompatible.;  */


	        error_table_$no_operation,		/*  no_oper , Invalid I/O operation.;  */
	        error_table_$no_record,		/*  no_rec  , Record not located.;  */
	        error_table_$noarg,			/*          , Expected argument missing.;  */
	        error_table_$not_attached,		/*  notattch, I/O switch (or device) is not attached.;  */
	        error_table_$not_closed,		/*  not_clsd, I/O switch is not closed.;  */
	        error_table_$not_detached,		/*  not_det , I/O switch is not detached.;  */
	        error_table_$not_open,		/*  not_open, I/O switch is not open.;  */
	        error_table_$request_not_recognized,	/*  reqnorec, Request not recognized.;  */
	        error_table_$termination_requested,	/*  termrqu , Process terminated because of system defined error condition.;  */
	        error_table_$user_not_found,		/*  usernfd , User-name not on access control list for branch.;  */
	        error_table_$unimplemented_version

	        )			 external static fixed bin (35);




	dcl     ipc_$delete_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     iox_$err_no_operation	 entry options (variable);
	dcl     iox_$err_not_closed	 entry options (variable);
	dcl     iox_$err_not_open	 entry options (variable);
	dcl     ioi_$timeout	 entry (fixed bin, fixed bin (52), fixed bin (35));
	dcl     ioi_$workspace	 entry (fixed bin, ptr, fixed bin (19), fixed bin (35));
	dcl     hcs_$make_seg	 entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
	dcl     hcs_$delentry_seg	 entry (ptr, fixed bin (35));
	dcl     iox_$propagate	 entry (ptr);
	dcl     ipc_$create_ev_chn	 entry (fixed bin (71), fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     ioi_$connect	 entry (fixed bin, fixed bin (18), fixed bin (35));
	dcl     ipc_$block		 entry (ptr, ptr, fixed bin (35));
	dcl     ioi_$set_status	 entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
	dcl     ioi_$get_detailed_status entry (fixed bin, bit (1) aligned, bit (*), fixed bin (35));
	dcl     timer_manager_$sleep	 entry (fixed bin (71), bit (2));
	dcl     hcs_$initiate	 entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
	dcl     hcs_$fs_get_mode	 entry (ptr, fixed bin (5), fixed bin (35));
	dcl     hcs_$set_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     hcs_$reset_ips_mask	 entry (bit (36) aligned, bit (36) aligned);
	dcl     default_handler_$set	 entry (entry);
	dcl     terminate_process_	 entry (char (*), ptr);
	dcl     rcp_$attach		 entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
	dcl     rcp_$check_attach	 entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71),
				 fixed bin, fixed bin (35));
	dcl     rcp_$detach		 entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
	dcl     a_iocb_ptr		 ptr;		/* parameter:  IOCB pointer */
	dcl     a_code		 fixed bin (35);	/* parameter:  return code */
	dcl     a_rec_len		 fixed bin (21);	/* parameter:  user record length */
	dcl     a_ubuf_ptr		 ptr;		/* parameter:  pointer to user buffer */
	dcl     a_ubuf_len		 fixed bin (21);	/* parameter: length (chars.) of user buffer */

	dcl     based_rsr_data	 (11) bit (8) unal based (addr (buffer.control_info.rsr_data));
	dcl     found		 bit (1) aligned;

	dcl     1 user_dev_char_table	 based (info_ptr) aligned, /* Users device Characteristics Table */
		2 user_subsystem_name char (4),	/* Disk subsystem name */
		2 user_device_name	 char (8),	/* Device name */
		2 user_sect_per_dev	 fixed bin (35),	/* total no. of non-T&D sectors on pack */
		2 user_cyl_per_dev	 fixed bin,	/* no. of non-T&D cylinders on pack */
		2 user_sect_per_cyl	 fixed bin,	/* no of sectors per cylinder */
		2 user_sect_per_track fixed bin,	/* no. of sectors per track */
		2 user_num_label_sect fixed bin,	/* no. of sectors to reserve for label */
		2 user_num_alt_sect	 fixed bin,	/* no. of sectors to reserve for alt. track area */
		2 user_sect_size	 fixed bin (12);	/* no. of words in sector */

	dcl     1 user_status_info	 based (info_ptr) aligned, /* user's status data */
		2 user_hardware_status bit (72),	/* iom status */
		2 user_dev_detail_status (11) bit (8) unal, /* 11 bytes of dev detail status */
		2 user_dev_cmd	 fixed bin;	/* the command issued to the disk */
	dcl     last_cmd_		 fixed bin static;	/* last command to experience an error */
%page;
	dcl     io_command		 char (8) varying;	/* values are "read", "write", or "rewrite" */
	dcl     current_mode_name	 char (24);	/* name of current opening mode */

	dcl     END		 fixed bin int static init (-5); /* used to indicate that a key is at the end of the file */
	dcl     NULL		 fixed bin int static init (-1); /* used to flag keys as currently being invalid */
	dcl     unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unique_entry_name	 char (22);
          dcl     length		 builtin;
%page;

/*  Start of ATTACH module  */

exdim_attach: entry (a_iocb_ptr, options_ptr, a_err_sw, a_code);


	dcl     options_ptr		 ptr;
	dcl     1 options_		 based (options_ptr), /* parameter:  attach description elements */
		2 number_opts	 fixed bin,
		2 options		 (number_opts) char (32) varying;


	dcl     a_err_sw		 bit (1) aligned;	/* parameter: print errors flag */


	code = 0;					/* clear return code */

	unique_entry_name = unique_chars_ ("0"b) || ".exdim_";
	call hcs_$make_seg ("", unique_entry_name, "", 01010b, disk_ptr, code); /* make our work segment */
	if disk_ptr = null then call error (code, "");	/* if it didn't work */

	err_sw = a_err_sw;				/* fill in print errors flag */
	iocb_ptr = a_iocb_ptr;			/* grab IOCB pointer */

	if iocb_ptr -> attach_descrip_ptr ^= null then call att_err (error_table_$not_detached);
						/* must be detached */

	write_sw, sys_sw, compare_sw = "0"b;		/* initialize switches */
	pack_id = " ";				/* clear pack id */
	sze = 0;					/* reset size field */
	drive = NOT_SET;				/* init drive field */
	drive_name = "";				/* no specific drive specified */
	model_number = 0;

	num_opts = options_.number_opts;		/* how many descrip. elements? */

	if num_opts >= 2 then do;			/* if enough */
		dev_id = options (1);		/* set device name */
		pack_id = options (2);		/* set pack id */
	     end;
	else call att_err (error_table_$noarg);		/* complain if not enough  */

	if dev_id = "d191" then dev_id = "d400";	/* set up for compatibility */
						/* ******** */
	else if dev_id = "d450" then dev_id = "d451";


	dev_type = 0;				/* clear device type indicator */
	do i = 1 to maxdevt while (dev_type = 0);	/*  look up dev. name in dev. char. table */
	     if dev_id = device_names (i) then dev_type = i; /* if found, set device type indicator */
	end;
						/* ******** */


	do i = 3 to num_opts;			/* check out attach options */

	     if options (i) = "-write" then write_sw = "1"b; /* if -write set write mode switch */


	     else if options (i) = "-device"
		| options (i) = "-dv"
	     then do;				/* -device device-name */
		     if i >= num_opts
		     then call att_err (error_table_$noarg);
		     i = i + 1;
		     drive_name = options (i);
		     if drive_name ^= options (i)
		     then call att_err (error_table_$bad_arg);
		end;


	     else if options (i) = "-system" | options (i) = "-sys"
	     then do;				/* if a reserved drive is wanted */

		     call hcs_$initiate (">system_library_1", "rcp_sys_", "", 0, 0, rs_ptr, code); /* test rcp_sys_ access */
		     if rs_ptr ^= null then do;	/* if can be initiated */
			     call hcs_$fs_get_mode (rs_ptr, rs_mode, code); /* check caller's access */
			     if code = 0 then if bit (rs_mode) & EXEC then sys_sw = "1"b; /* if execute, then priv. process */
			end;
		     if ^sys_sw then call att_err (error_table_$user_not_found); /* User does not have correct access to rcp_sys_ gate. */
		end;

	     else call att_err (error_table_$request_not_recognized); /* if not valid option, complain */

	end;

	if dev_type = 0
	then attach_descrip.descrip = "exdim_ """" " || pack_id;
	else attach_descrip.descrip = "exdim_ " || device_names (dev_type) || " " || pack_id; /* init. att. descrip. */
	attach_descrip.length = length (rtrim (attach_descrip.descrip));
	do i = 3 to num_opts;			/* add the options */
	     attach_descrip.descrip = substr (attach_descrip.descrip, 1, attach_descrip.length)
		|| " " || options (i);		/* concatenate the next option */
	     attach_descrip.length = length (rtrim (attach_descrip.descrip));
	end;

	call ipc_$create_ev_chn (ev_chan, code);	/* create an event channel */
	if code ^= 0 then call att_err (code);		/* if we didn't make it */
	nchan = 1;				/* only one channel */

	disk_info_ptr = addr (rcp_data);		/* init. disk info prior to assignment */
	disk_info.version_num = DISK_INFO_VERSION_1;
	disk_info.usage_time, disk_info.wait_time = 0;
	disk_info.system_flag = sys_sw;
	if dev_type ^= 0
	then disk_info.model = MODELN (dev_type);
	else disk_info.model = 0;
	disk_info.device_name = drive_name;
	disk_info.write_flag = write_sw;
	raw_sw = "0"b;				/* reset raw mode if set */
	alt_sw = "0"b;
	label_sw = "1"b;
	call mount ();				/* attach drive, and mount pack */
	if code ^= 0 then call att_err (code);		/* complain if we didn't make it */

	dev_type = 0;
	do i = 1 to hbound (MODELN, 1) while (dev_type = 0);
	     if disk_info.model = MODELN (i)
	     then dev_type = i;
	end;


	device_group = DEVICE_GROUP (dev_type);

	sect_per_dev = sect_per_cyl (dev_type) * cyl_per_dev (dev_type); /* Set up device specific constants */
	sect_size = words_per_sect (dev_type);
	num_alt_sect = last_alt_sect_num (dev_type) - first_alt_sect_num (dev_type) + 1;

	if sys_sw then bounds.low = 0;
	else bounds.low = num_label_sect;		/* initialize the seek low bound */
	if device_group = MSU04XX
	then bounds.high = last_alt_sect_num (dev_type);
	else bounds.high = last_sect_num (dev_type);

	mode_string = "label,^alttrk,^wrtcmp,^raw";	/* set the modes string */

	mask_str = "0"b;				/* initialize ips_ mask */
	call default_handler_$set (cond_hdlr);		/* protect ourselves */
	call hcs_$set_ips_mask (mask_str, mask_str);

	iocb_ptr -> attach_descrip_ptr = addr (attach_descrip); /* fill in IOCB; attach descrip. */
	iocb_ptr -> attach_data_ptr = disk_ptr;		/* attach data */
	iocb_ptr -> detach_iocb = exdim_detach;		/* detach entry */
	iocb_ptr -> iocb.open = exdim_open;		/* open entry */
	iocb_ptr -> iocb.control = exdim_control;	/* control entry */
	iocb_ptr -> iocb.modes = exdim_modes;		/* modes entry */

	call iox_$propagate (iocb_ptr);		/*  let iox_ have its turn */

	call hcs_$reset_ips_mask (mask_str, mask_str);	/* back to normal */

	next_key, current_key, key_for_insertion = NULL;	/* Change when valid values established */


exit:	a_code = code;				/* return the code */
	return;					/* bye-bye */
%page;
/*  Internal handler for errors occurring during ATTACH  */

att_err: proc (b_code);

	dcl     (b_code, c_code)	 fixed bin (35);	/* error code */

	c_code = b_code;

	call hcs_$delentry_seg (disk_ptr, c_code);	/* get rid of work segment */
	code = b_code;				/* set code */
	go to exit;				/* return */

     end att_err;


/*  End of ATTACH module  */
%page;
/*  Start of OPEN module  */

exdim_open: entry (a_iocb_ptr, a_mode, a_code);

/*
   *           Only the direct_update and direct_input opening modes are
   *           supported:

   *           Note that the  attach  description  must  include the  -write

   *           control  argument  so  that  the operator  will not  press  the

   *           PROTECT button when pack is mounted if direct_update is used.
*/

	dcl     a_mode		 fixed bin;	/* parameter:  open mode  */

	call setup ("closed");			/* set up working environment */
						/* If setup returns to here, the switch is closed. */

	mode = a_mode;				/* pick up requested opening mode */


/*  Set up various items which are opening-mode dependent.  */
/*  Since current_key remains NULL for all modes, it is not changed and hence does not show below. */



	if mode = Direct_update then do;
		if ^write_sw then call error (error_table_$incompatible_attach,
			"direct_update requires -write control arg."); /* complain if not attached for write */
		open_descrip.length = 13;
		open_descrip.descrip = "direct_update";
		real_iocb_ptr -> read_record = exdim_read;
		real_iocb_ptr -> rewrite_record = exdim_rewrite;
		real_iocb_ptr -> seek_key = exdim_seek;
						/* next_key remains NULL */
		fill = "000000000"b;		/* Zero fill last sector when write. */
	     end;


	else if mode = Direct_input then do;
		open_descrip.length = 12;
		open_descrip.descrip = "direct_input";
		real_iocb_ptr -> read_record = exdim_read;
		real_iocb_ptr -> seek_key = exdim_seek;
						/* next_key remains NULL */
		fill = "110110110"b;		/* Should never be used. */
	     end;


	else do;					/* complain if an invalid opening mode was requested. */
		current_mode_name = iox_modes (mode);
		call error (error_table_$request_not_recognized, current_mode_name); /* complain if invalid opening mode */
	     end;


	mask_str = "0"b;				/* initialize ips_ mask */
	call default_handler_$set (cond_hdlr);		/* protect ourselves */
	call hcs_$set_ips_mask (mask_str, mask_str);

/*  The file is now open.  Set up to allow a close, but not an open or detach. */

	real_iocb_ptr -> close = exdim_close;
	real_iocb_ptr -> open,
	     real_iocb_ptr -> detach_iocb = iox_$err_not_closed;


	real_iocb_ptr -> open_descrip_ptr = addr (open_descrip); /* fill in IOCB open descrip. pointer */

	call iox_$propagate (iocb_ptr);		/* let iox_ have a turn again */

	call hcs_$reset_ips_mask (mask_str, mask_str);	/* back to normal */

	a_code = 0;				/* give successful code */
	return;					/* auf wiedersehen */

/*  End of OPEN module  */
%page;
/*  Start of SEEK module  */

exdim_seek: entry (a_iocb_ptr, a_key, a_rec_len, a_code);

/*
   *      S__e_e_k_K__e_y_O__p_e_r_a_t_i_o_n


   *           This operation returns a status code of 0 for any key that  is  a
   *      valid  sector  number.   The  record  length  returned  is  always 256
   *      (current physical sector size in characters) for any valid  key.   The
   *      specified key must be a character string that could have been produced
   *      by  editing  through  a  PL/I picture of "(8)9".
   *      This operation is supported for only the direct opening modes.
*/

	dcl     a_key		 char (256) varying;/* parameter:   key to seek on  */

	call setup ("open");			/* set up working environment */
	if mode = Direct_input | mode = Direct_update then ;
	else call error (error_table_$no_record, "seek valid only for direct openings.");

	temp_key = cv_dec_check_ (ltrim (rtrim (a_key)), code);
	if code ^= 0
	then call error (error_table_$no_record, (a_key));

	if (temp_key < bounds.low) | (temp_key > bounds.high) then
	     call error (error_table_$no_record, "Requested sector outside available area.");
	else next_key, current_key = temp_key;
						/* key_for_insertion is not changed */

	a_rec_len = 4 * sect_size;			/* return canned rec. len. of sect. size (chars.) */
	a_code = 0;				/* and good code */
	return;					/* 'til next time */

/*  End of SEEK module  */
%page;

/*  Start of READ and WRITE modules  */

exdim_read: entry (a_iocb_ptr, a_ubuf_ptr, a_ubuf_len, a_rec_len, a_code);

/*
   *	     If the amount of data to be read does  not  terminate  on  a
   *	sector  boundary,  the  excess portion of the last sector will be
   *	discarded.  A zero code will be  returned  in  this  case.
*/

	call setup ("open");			/* set up working environment */


	if next_key = NULL then
	     call error (error_table_$no_record, "next_key must be non-null to read");
	else if next_key = END then do;
		next_key = NULL;
		current_key = NULL;
		call error (error_table_$device_end, "Attempted to read (di, du) past end of avilable area.");
	     end;
	io_command = "read";			/* set switch for read */

	rec_len = a_ubuf_len;
	a_rec_len = 0;
	key = next_key;				/* set working key value */
	go to read_write_common;			/* proceed  to common code */
%page;
exdim_rewrite: entry (a_iocb_ptr, a_ubuf_ptr, a_rec_len, a_code);

/*
   *           If the amount of data to be  written  does  not  terminate  on  a
   *      sector  boundary,  the  remaining portion of the last sector is filled
   *      with  spaces in  sequential modes and binary zeros in direct modes.  A
   *      code  of 0  is returned  in  this  case.  This
   *      operation is supported for only the update opening modes.
*/

	call setup ("open");			/* set up working environment */

	if current_key = NULL then
	     call error (error_table_$no_record, "Attempted to rewrite before the start of the file.");
	else if current_key = END then do;
		next_key = END;
		call error (error_table_$device_end, "Attempted to rewrite when already at the end of the file.");
	     end;

	io_command = "rewrite";			/* set switch for rewrite */


	rec_len = a_rec_len;			/* set output record length */
	key = current_key;				/* set working key */

%page;
read_write_common:

/*
   *      For  all other opening modes, if an attempt is made to read or
   *      write beyond the end of the user-accessible area on disk, the  code
   *      error_table_$device_end  is   returned.   If  a  defective  track  is
   *      encountered or if any other unrecoverable data transmission  error  is
   *      encountered, the code error_table_$device_parity is returned.
   *
   *           The  record length is specified through the buff_len parameter in
   *      the read_record operation, and through the rec_len parameter  for
   *      rewrite  operation.
*/

	dcl     sectors_for_record	 fixed bin;	/* Qty. of sectors necessary to hold the record to be written */
	dcl     potential_next_sector	 fixed bin (21);	/* Tentative address of sector immediately following the last */
						/* sector this record will occupy if this is a write. */

	sectors_for_record = ceil (rec_len / (4 * sect_size));

	potential_next_sector = key + sectors_for_record;

	if key = NULL then do;			/* if he didn't do a seek */
		code = error_table_$no_record;	/* complain */
		call io_err ("0"b);
	     end;

	if io_command = "rewrite" then
	     if potential_next_sector > bounds.high + 1 then
		call error (error_table_$no_operation, "Record will not fit in space left on disk.");

	ubuf_ptr = a_ubuf_ptr;			/* grab pointer to user buffer */

	track_indicators = "00"b;			/* reset ti bits if set */



/*  if record longer than maximum or current ioi_ buffer size */


	if (rec_len > 4 * (floor ((max_buff_size - overhead) / sect_size) * sect_size))
	     | (rec_len > 4 * floor (data_len / sect_size) * sect_size) then
	     call error (error_table_$no_operation, "Invalid record length.");


	block_ptr = ubuf_ptr;			/* initialize block pointer */
	block_len = ceil (ceil (rec_len / 4) / sect_size) * sect_size; /* and block length */
	data_left = rec_len;			/* and data left to xmit */
	call do_io;				/* go do the I/O  */


io_succeeded:

/* 			PATH 1 */

	if io_command = "read" then do;

		current_key = next_key;
		a_rec_len = rec_len;		/* Send back length of data actually read. */
		next_key = NULL;			/* mode = direct_update */


	     end;


/* 			PATH 2 */

	else if io_command = "rewrite" then /* No change to  current_key  */

	     next_key = NULL;			/* mode = direct_update */


/* Do this every time, for any case */

	a_code = 0;				/* give good  code */
	return;					/* come again, sometime */

%page;

/*  Internal Procedure to  reset certain fields after the occurrence of an I/O error  */

io_err: proc (clear_space);

	dcl     clear_space		 bit (1);		/*  flag to tell us to zap ioi_ workspace */

	if clear_space then do;			/* if space  no good */
		buf_ptr = null;			/* zap it!! */
		buf_len, data_len = 0;
	     end;

	call error (code, "");			/* let user know */

     end io_err;

%page;

/*  Internal procedure to actually perform I/O  */

do_io: proc;

	dcl     (true_len, data_read)	 fixed bin (35);	/* internal data  manipulation variables */

	true_len = min (4 * block_len, data_left);	/* set true amount to xmit */


/* If we are going to write onto the disk, fill in unused area at end of the disk sector
   with zeros for direct opening modes
   or with ASCII spaces for sequential opening modes. */
/*  and fill in unused space with zeros */

	if io_command ^= "read" then do;		/* if an output command  */
		substr (data, 1, true_len) = substr (block, 1, true_len); /* move data to ioi_ buffer */
		if true_len < 4 * block_len then unspec (substr (data, true_len + 1, 4 * block_len - true_len)) = fill;
	     end;

	idcwp = addr (sk_idcw);			/* get pointer to  seek IDCW */
	idcw = seek_idcw_template;			/* move in template seek IDCW */
	idcw.device = bit (drive);			/* set drive no. */
	count_limit_fixed = ceil (block_len / sect_size); /* and sector  count limit  in seek data */

	if key <= last_sect_num (dev_type)		/* in the data region */
	then goto BUILD_DATA_SEEK (device_group);
	else if key <= last_alt_sect_num (dev_type)	/* in the alternate region */
	then goto BUILD_ALT_SEEK (device_group);

	else
	     call error (error_table_$no_record, "Requested record outside available area.");


BUILD_DATA_SEEK (1):				/* Data region on MSU04XX device */
BUILD_ALT_SEEK (1):					/* Alternate track region on MSU04XX device */
BUILD_DATA_SEEK (2):				/* Data region on MSU0500/1 device */
BUILD_NORMAL_SEEK:

	unspec (seek) = "0"b;
	seek.block_count_limit = count_limit_fixed;
	seek.ti = track_indicators;
	seek.sector = key;
	unspec (seek_data) = unspec (seek);
	goto SEEK_BUILT;


BUILD_ALT_SEEK (2):					/* Alternate track region on MSU0500/1 device */


	idcw.command = SPECIAL_SEEK;


BUILD_SUPER_SEEK:

	unspec (super_seek) = "0"b;
	super_seek.sector_number = mod (key, sect_per_track (dev_type));
	super_seek.ti = track_indicators;
	super_seek.is_super_seek = "1"b;
	super_seek.flag = "1"b;			/* ON => sector number in 0-12 rather than block count limit */
	cyl = divide (key, sect_per_cyl (dev_type), 16, 0);
	head = mod (key, sect_per_cyl (dev_type));
	head = divide (head, sect_per_track (dev_type), 16, 0) * 2 + mod (cyl, 2);
	if mod (cyl, 2) = mod (drive, 2) then /* see EPS for details of this crock */
	     if mod (cyl, 2) = 0 then cyl = cyl + 1;
	     else cyl = cyl - 1;
	super_seek.cyl_lower = mod (cyl, 256);
	super_seek.cyl_upper = divide (cyl, 256, 2, 0);
	super_seek.head = head;
	unspec (seek_data) = unspec (super_seek);
	goto SEEK_BUILT;


BUILD_DATA_SEEK (3):				/* Data region on MSU3380 & MSU3381 devices */

	idcw.command = SEEK_512;
	goto BUILD_NORMAL_SEEK;


BUILD_ALT_SEEK (3):					/* Alternate track region on MSU3380 & MSU3381 devices */


	idcw.command = SPECIAL_SEEK_512;
	goto BUILD_SUPER_SEEK;


SEEK_BUILT:					/* Seek command and data are ready */

	dcwp = addr (sk_dcw);			/* get pointer to seek DCW */
	dcw = seek_dcw_template;			/* put in canned value */
	dcw.address = rel (addr (seek_data));		/* fill in data address */

	idcwp = addr (rw_idcw);			/* get pointer to read/write IDCW */

	if (io_command = "read") then idcw = read_idcw_template; /* if read, put in canned read value */
	else if compare_sw then /*  put in compare comd. if in that mode */
	     idcw = write_and_compare_idcw_template;
	else idcw = write_idcw_template;		/* normal write */


	idcw.chan_cmd = INHIB_AUTO_RETRY;		/* inhibit mpc auto retries */
	idcw.device = bit (drive);			/*  fill in drive number */

	dcwp = addr (rw_dcw);			/* get pointer to read/write DCW */
	dcw = read_write_dcw_template;		/* put in canned value */
	dcw.address = rel (addr (data));		/* fill in data address */
	dcw.tally = bit (block_len);			/* fill in tally */

	dcw_offset = fixed (rel (addr (sk_idcw)));	/* set offset for ioi_ */

	again = "1"b;				/* so we do it at least once */
	err_ct = 0;				/* init. error count */

	do while (again);				/* I/O loop */

	     completion.st = "0"b;			/* initialize status entry */
	     completion.run = "1"b;

	     call ioi_$connect (devx, dcw_offset, code);	/* Start I/O */
	     if code ^= 0 then call io_err ("0"b);	/* didn't get away from the starting line */

	     do while (^completion.st & completion.run);	/* while connected and no status */

		call ipc_$block (addr (wait_list), addr (event_info), code); /* wait for completion */
		if code ^= 0 then call io_err ("0"b);	/* No loiterers?? */

	     end;

	     again = "0"b;				/* set for no retry */

	     if completion.time_out |
		^(completion.st | completion.er | completion.run | completion.time_out) /* if nothing */
	     then call retry;			/* try again */

	     else if level <= 1 then call perm_err;	/* if fault */

	     else if level > 3 then call retry;		/* if special or marker */

	     else if status.maj = ATTENTION then
		if status.sub & STANDBY then call delay_retry; /* other MPC may have control */
		else call perm_err;			/* just plain attention, let user know */

	     else if status.maj = EOF then
		if (status.sub & LAST_BLOCK_MASK = LAST_BLOCK) then do; /* if we've run off end of the pack */
			if (io_command = "read") then do; /* and we were reading */
				data_read = min (true_len, (block_len - fixed (status.residue) - 1) * 4); /* amount read */
				substr (block, 1, data_read) = substr (data, 1, data_read); /* give user what we can */
				a_rec_len, rec_len = rec_len - data_left + data_read; /* and tell him how much */
				unspec (substr (block, rec_len + 1, data_left - data_read)) = fill;
						/* spaces for sequential; zeros for direct */
			     end;


			else code = error_table_$device_end; /* all other modes */


			call io_err ("0"b);		/* tell user */
		     end;

		else call perm_err;			/* any other EOF is bad news */

	     else if status.maj ^= "0000"b then call perm_err; /* don't beat a dead horse */

	end;

	if (io_command = "read") then do;		/* if normal read command */
		substr (block, 1, true_len) = substr (data, 1, true_len); /* give the user his data */
		rec_len = true_len;			/* Send back length of data actually read. */
	     end;


     end do_io;

%page;

/*  Internal procedure to retry I/O  */

retry: proc;

	if status.maj ^= ATTENTION then err_ct = err_ct + 1; /* don't keep track of attentions */

	if err_ct <= max_retries then do;		/* is it worth while? */
		idcwp = addr (rst_idcw);		/* yes, get pointer to restore IDCW */
		idcw = restore_idcw_template;		/* put in canned restore value */
		idcw.device = bit (drive);		/* fill in drive no. */
		dcw_offset = fixed (rel (addr (rst_idcw))); /* set up offset for ioi_ */
		again = "1"b;			/* and set flag to try again */
	     end;
	else call perm_err;				/* our patience has worn thin */

     end retry;

%page;

/*  Internal procedure to handle ATTENTION status with STANDBY sub-status.  */

delay_retry: proc;

/*  Have been told that this status occurs in dual-MPC configurations
   if the other MPC has the device.  This procedure merely delays for a
   short time, and then retries.  */

	err_ct = err_ct + 1;			/* keep track of how often we do this */

	if err_ct >= max_retries then do;		/* if too often */
		err_ct = 0;			/* reset error count */
		call perm_err;			/* let user decide what to do */
	     end;
	else do;
		call timer_manager_$sleep (500000, "10"b); /* delay for 1/2 sec.  */
		call retry;			/* and try again */
	     end;

     end delay_retry;

%page;


/*  Internal procedure to handle permanent I/O errors  */

perm_err: proc;




	idcwp = addrel (buf_ptr, offset);		/* look at the offending DCW chain */
	do while (idcw.code ^= "111"b & fixed (rel (idcwp)) > 0); /* look for IDCW or beginning of seg */
	     idcwp = addrel (idcwp, -1);		/* back track */
	end;
	dcwp = addrel (idcwp, 1);			/* set to corresponding DCW */
	disk_info_ptr = addr (rcp_data);		/* initialize pointer first */
	call ioi_$get_detailed_status (devx, found, buffer.control_info.rsr_data, code);
	last_cmd_ = fixed ((substr (idcw.command, 1, 6)), 6);

	if level <= 1 then do;
		call com_err_ (0, "exercise_disk:",
		     "Unrecoverable error on ^a device ^a, sector ^o (^d.).^/IOM Status:^-^w ^w^/IDCW/DCW Pair:^-^w ^w",
		     device_names (dev_type), disk_info.device_name, key, key,
		     substr (iom_stat, 1, 36), substr (iom_stat, 37, 36), idcw, dcw);

	     end;
	errors = errors + 1;			/* increment pack  error count */

	code = error_table_$device_parity;		/* tell user about his misfortune */
	goto exit;

     end perm_err;

%page;

/*  Start of CONTROL module  */

exdim_control: entry (a_iocb_ptr, order, a_info_ptr, a_code);

/*
   *	     The  following  orders  are supported when the I/O switch is
   *	open, except for getbounds, which is supported while  the  switch
   *	is attached.
*/

	dcl     order		 char (*);	/* parameter: the control order */
	dcl     a_info_ptr		 ptr;		/* parameter:  pointer to supplemental information */

	call setup ("don't_care");			/* set up working environment */

	if order ^= "getbounds" then if real_iocb_ptr -> open_descrip_ptr = null then
		call error (error_table_$not_open,
		     "Only getbounds is allowed when file is not open.");

	info_ptr = a_info_ptr;			/* grab pointer to additional info */

	if order = "getbounds" then do;		/* process the "getbounds" order */
		user_bounds.low = bounds.low;		/* pass back the low bound */
		user_bounds.high = bounds.high;	/* and the high bound */
	     end;					/*  getbounds  */


	else if order = "disk_info" then do;		/* process the disk_info order */
		disk_info_ptr = addr (rcp_data);
		if info_ptr -> disk_info.version_num ^= disk_info.version_num
		then do;
			a_code = error_table_$unimplemented_version;
			return;
		     end;
		info_ptr -> disk_info = disk_info;
	     end;

	else if order = "device_info" then do;		/* process the device_info order */
		disk_info_ptr = addr (rcp_data);	/* initialize pointer first */
		user_dev_char_table.user_subsystem_name = device_names (dev_type);
		user_dev_char_table.user_device_name = disk_info.device_name;
		user_dev_char_table.user_sect_per_dev = sect_per_dev;
		user_dev_char_table.user_cyl_per_dev = cyl_per_dev (dev_type);
		user_dev_char_table.user_sect_per_cyl = sect_per_cyl (dev_type);
		user_dev_char_table.user_sect_per_track = sect_per_track (dev_type);
		user_dev_char_table.user_num_label_sect = num_label_sect;
		user_dev_char_table.user_num_alt_sect = num_alt_sect;
		user_dev_char_table.user_sect_size = sect_size;
	     end;



	else if order = "hardware_status" then do;	/* give user the hardware details */
		user_hardware_status = iom_stat;
		user_dev_detail_status = based_rsr_data;
		user_dev_cmd = last_cmd_;
	     end;

	else call error (error_table_$no_operation, order); /* if bad order,  tell the user */

	a_code = 0;				/* made it */
	return;					/* au revoir */

/*  End of CONTROL module  */

%page;

/*  Start of MODES module  */

exdim_modes: entry (a_iocb_ptr, a_new_modes, a_code);

/*
   *	     The modes operation is supported  when  the  I/O  switch  is
   *	attached. Each mode has a complement indicated by the character
   *      "^" (e.g. "^label")  that turns the mode off.
   *
*/

	dcl     a_new_modes		 char (*);	/* parameter: new modes string */
	dcl     temp_next_mode	 char (16);	/* for type conversion for call error */

	call setup ("don't_care");			/* set up working environment */

	mode_len = length (a_new_modes);		/* see how much we've got */
	if mode_len > 0 then do;			/* if something */

		new_modes = a_new_modes;		/* grab the new modes */
		mode_start = 1;			/* keep track of where we are in the string */

		do while (next_mode ^= "");		/* mode processing loop */

		     call get_next_mode;		/* extract a  mode */
		     if next_mode ^= "" then do;	/* if we got one, do something with it */

			     mode_err_sw = "0"b;	/* give user  the benefit of the doubt */

			     if next_mode = "label"
			     then do;
				     bounds.low = num_label_sect; /* reserve label area */
				     label_sw = "1"b;
				end;
			     else if next_mode = "^label"
			     then do;
				     bounds.low = 0;/* let him  play,starting at sect. 0 */
				     label_sw = "0"b;
				end;

			     else if (next_mode = "alttrk")
			     then do;
				     bounds.high = last_sect_num (dev_type); /* reserve alternate track area */
				     alt_sw = "1"b;
				end;
			     else if next_mode = "^alttrk"
			     then do;
				     if device_group = MSU04XX
				     then bounds.high = last_alt_sect_num (dev_type);
				     else bounds.high = last_sect_num (dev_type);
				     alt_sw = "0"b;
				end;

			     else if next_mode = "wrtcmp" then compare_sw = "1"b; /* set compare mode switch */
			     else if next_mode = "^wrtcmp" then compare_sw = "0"b; /* set for ordinary write */

			     else if next_mode = "raw" then do;
				     bounds.low = 0;/* let user have entire pack in this mode */
				     bounds.high = last_physical_sect_num (dev_type);
				     raw_sw = "1"b; /* set indicator */
				end;
			     else if next_mode = "^raw" then do;
				     if label_sw	/* in label mode */
				     then bounds.low = num_label_sect; /* reset origial defaults */
				     else bounds.low = 0;
				     if ^alt_sw /* in alt mode */
					& device_group = MSU04XX /* and on a 400 series device */
				     then bounds.high = last_alt_sect_num (dev_type);
				     else bounds.high = last_sect_num (dev_type);
				     raw_sw = "0"b; /* reset raw indicator */
				end;
			     else do;		/* oh oh */
				     code = error_table_$bad_mode; /* tried to fool mother exdim_, eh?  */
				     mode_err_sw = "1"b; /* can't let that happen */
				end;

			     if ^mode_err_sw then call set_mode; /* update the mode string */

			end;
		end;
	     end;

	temp_next_mode = next_mode || "                "; /* obtain proper type for */
	temp_next_mode = substr (temp_next_mode, 1, 16);	/* the call to error */
	if code ^= 0 then call error (code, temp_next_mode); /* let him know how he did */
	else a_code = 0;

	return;					/* don't rush off */

/*  Internal procedure to extract single modes from the mode string  */

get_next_mode: proc;

	if mode_len > 0 then do;			/* if we still have something left */

		new_modes = substr (new_modes, mode_start, mode_len); /* update work string */

		i = index (new_modes, ",");		/* set i to length of next mode + 1 */
		if i = 0 then do;
			i = index (new_modes, " ");
			if i = 0 then i = mode_len + 1;
		     end;

		mode_len = mode_len - i;		/* keep track of how much we have left */
		mode_start = i + 1;			/* and where to start */
		next_mode = substr (new_modes, 1, i - 1); /* pass back the mode */

	     end;

	else next_mode = "";			/* nothing to return */

     end get_next_mode;

/*  Internal procedure to update the mode string  */

set_mode: proc;

	not_sw = (substr (next_mode, 1, 1) = "^");	/* set switch if a  "^" mode */

	i = index (mode_string, substr (next_mode, 1 + fixed (not_sw))); /* point to basic mode */

	if i <= 1 then if not_sw then mode_string = "^" || mode_string; else ; /* if at beg. just prefix "^" */

	else if not_sw & (substr (mode_string, i - 1, 1) ^= "^") /* insert a  "^" */
	then substr (mode_string, i) = "^" || substr (mode_string, i);

	else if ^not_sw & (substr (mode_string, i - 1, 1) = "^") then /* delete a "^" */
	     substr (mode_string, i - 1) = substr (mode_string, i);

     end set_mode;

/*  End of MODES module  */

%page;

/*  Start of CLOSE module  */

exdim_close: entry (a_iocb_ptr, a_code);

/*
   This operation has no effect on the device, but merely  resets some
   fields in the IOCB.
*/

	call setup ("open");			/* set up working environment */

	mask_str = "0"b;				/* initialize ips_ mask */
	call default_handler_$set (cond_hdlr);		/* protect ourselves */
	call hcs_$set_ips_mask (mask_str, mask_str);

	real_iocb_ptr -> open_descrip_ptr = null;	/* put IOCB in closed state;  open descrip. pointer */

	real_iocb_ptr -> open = exdim_open;		/* set open entry */
	real_iocb_ptr -> detach_iocb = exdim_detach;	/* and detach entry */

	real_iocb_ptr -> close,			/* shut the close entry */
	     real_iocb_ptr -> read_record,		/* and the read record entry */
	     real_iocb_ptr -> rewrite_record,		/* and the rewrite record entry */
	     real_iocb_ptr -> position,		/* and the position entry */
	     real_iocb_ptr -> write_record,		/* and the write record entry */
	     real_iocb_ptr -> seek_key = iox_$err_not_open; /* and the seek key entry */

	call iox_$propagate (iocb_ptr);		/* give iox_ a turn */

	call hcs_$reset_ips_mask (mask_str, mask_str);	/* back to normal */

	next_key, current_key, key_for_insertion = NULL;	/* reset all keys to invalid state */

	a_code = 0;				/* be nice to him */
	return;					/* and he may call us again, sometime */

/*  End of CLOSE module  */
%page;
/*  Start of DETACH  module  */

exdim_detach: entry (a_iocb_ptr, a_code);

/*
   This operation dismounts and detaches the device, and cleans up the IOCB.
*/

	call setup ("closed");			/* set up working environment */

/* The following code dismounts the pack.  It can be deleted when RCP gets around to doing this. */

	if media_removable (dev_type)
	then do;					/* unload the pack */
		idcwp = addr (rst_idcw);		/* use the restore IDCW slot */
		idcw = standby_idcw_template;		/* and put in canned standby idcw */
		idcw.device = bit (drive);		/* fill in drive number */
		dcw_offset = fixed (rel (addr (rst_idcw))); /* and offset  for ioi_ */
		call ioi_$connect (devx, dcw_offset, code); /* start it up, we won't wait for it to finish */
	     end;


	call rcp_$detach (rcp_id, (DEFAULT), errors, "", code); /* detach the device */

	call ipc_$delete_ev_chn (ev_chan, code);	/* get rid of event channel */

	call hcs_$delentry_seg (disk_ptr, code);	/* get rid of work segment */
	disk_ptr = null;				/* null the pointer */

	mask_str = "0"b;				/* initialize ips_ mask */
	call default_handler_$set (cond_hdlr);		/* protect ourselves */
	call hcs_$set_ips_mask (mask_str, mask_str);

	iocb_ptr -> attach_data_ptr = null;		/* clean up the IOCB;  null the data pointer */
	iocb_ptr -> attach_descrip_ptr = null;		/* and the attach descrip. pointer */

	iocb_ptr -> iocb.control,			/* reset control */
	     iocb_ptr -> iocb.modes = iox_$err_no_operation; /* and modes operations */

	call iox_$propagate (iocb_ptr);		/* tell iox_ */

	call hcs_$reset_ips_mask (mask_str, mask_str);	/* back to normal */

	if code ^= 0 then call error (code, "Problem in detaching."); /* tell user if something went wrong */

	a_code = 0;				/* otherwise, give him a good send-off */
	return;

/*  End of DETACH module  */
%page;
/*  Internal SETUP Procedure  */

setup: proc (setup_input_arg);

	dcl     setup_input_arg	 char (*);
	dcl     desired_switch_state	 char (12) varying;

/*  call setup ("open")       means the switch should be open   -- complain if it is closed.  */
/*  call setup ("closed")       "    "     "     "    "  closed --    "     "  "  "    open.  */
/*  call setup ("don't_care") means that the switch can be either open or closed.  */

	dcl     who_did_the_attach	 char (6);	/*  Which I/O module attached this file?  */
	dcl     setup_error_msg	 char (36);	/*  temporary error message  */

	code = 0;					/* give him a chance to make it */

	desired_switch_state = setup_input_arg;
	iocb_ptr = a_iocb_ptr;			/* pick up pointer to IOCB */
	real_iocb_ptr = iocb_ptr -> actual_iocb_ptr;	/* the real one, this time */
	disk_ptr = real_iocb_ptr -> attach_data_ptr;	/* and a pointer to our work seg */

	if real_iocb_ptr -> attach_descrip_ptr = null then
	     call error (error_table_$not_attached, "");
						/*  must be attached */

	who_did_the_attach = substr (attach_descrip.descrip, 1, index (attach_descrip.descrip, " ") - 1);
	if who_did_the_attach ^= "exdim_" then do;
		setup_error_msg = "Not attached by exdim_ but by " || who_did_the_attach;
		call error (error_table_$not_attached, setup_error_msg);
	     end;


	if desired_switch_state = "open" then
	     if real_iocb_ptr -> open_descrip_ptr = null then
		call error (error_table_$not_open, "");

	     else if desired_switch_state = "closed" then
		if real_iocb_ptr -> open_descrip_ptr ^= null then
		     call error (error_table_$not_closed, "");

		else if desired_switch_state = "don't_care" then
		     return;

     end setup;
%page;

/*  Internal ERROR Procedure  */

error: proc (cd, err_msg);

	dcl     cd		 fixed bin (35);	/* code */
	dcl     err_msg		 char (*);	/* Additional text. */

	code = cd;				/* set code */
	go to exit;				/* and exit, stage right */

     end error;

%page;

/*  Internal PACK MOUNT procedure  */

mount: proc;


	errors = 0;				/* give the pack a fresh start */

	disk_info_ptr = addr (rcp_data);		/* init. disk info prior to attaching device */
	disk_info.volume_name = pack_id;		/* fill in new pack id */

	call rcp_$attach ((rcp_dev_type), disk_info_ptr, ev_chan, "", rcp_id, code); /* attach device */
	if code ^= 0 then return;			/* let caller handle problems */

	call rcp_$check_attach (rcp_id, disk_info_ptr, "", devx, max_buff_size, (time_int), rcp_state, code);
	if code ^= 0 then return;			/* check attachment completion */

	do while (rcp_state ^= COMPLETE);		/* loop until attachment is complete or fails */
	     on cleanup call detach;			/* detach disk if user aborting */
	     call ipc_$block (addr (wait_list), addr (event_info), code); /* wait to hear from rcp_ */
	     revert cleanup;
	     if code ^= 0 then return;
	     call rcp_$check_attach (rcp_id, disk_info_ptr, "", devx, max_buff_size, (time_int), rcp_state, code);
	     if code ^= 0 then return;		/* let caller worry about it */
	     if rcp_state < COMPLETE | rcp_state >= LONG_WAIT then do;
		     code = error_table_$action_not_performed; /* let user know he has a problem */
		     return;			/* let caller pass bad news to user */
		end;
	end;

	if drive = NOT_SET then do;
		drive_number.sign = "+";		/* successful assignment, convert and save drive number */
		drive_number.number = substr (disk_info.device_name, 6, 2);
		drive = drive_dec;
	     end;

	buf_len = min (max (divide (sze, 4, 17, 0), 1024), max_buff_size); /* determine ioi_ buffer size */
	call ioi_$workspace (devx, buf_ptr, buf_len, code); /* and try to get it */
	if code ^= 0 then return;			/* win some -- lose some */
	data_len = buf_len - overhead;		/* set length of data area */

	call ioi_$set_status (devx, fixed (rel (addr (istat))), 1, code); /* tell ioi_ how to reach us */
	if code ^= 0 then return;

	call ioi_$timeout (devx, time_int, code);	/* have ioi_ do it */
	if code ^= 0 then return;			/* how do you like that! */

detach: proc;
	call rcp_$detach (rcp_id, "0"b, (0), "", (0));
	return;
     end detach;

     end mount;

%page;

/*  Internal CONDITION HANDLER */

cond_hdlr: proc (mc_ptr, cond_name, wc_mc_ptr, info_ptr, cont_sw);

/*
   This procedure handles any unusual conditions signaled while we are
   masked by terminating the process.  This avoids problems we
   would have if we attempted to use an IOCB  which was left in an
   inconsistent state.
*/
	dcl     (mc_ptr, wc_mc_ptr, info_ptr) ptr;
	dcl     cond_name		 char (*);	/* condition name */
	dcl     cont_sw		 bit (1) aligned;	/* continuation switch */

	if masked then do;				/* if we were masked, kill the process */
		tp_info.version = 0;		/* currently version 0 */
		tp_info.code = error_table_$termination_requested; /* as good a reason as any */
		call terminate_process_ ("fatal_error", addr (tp_info)); /* do the dirty deed */
	     end;

	if cond_name ^= "cleanup" then cont_sw = "1"b;	/* don't pass on cleanup */

     end cond_hdlr;



     end exdim_;

%page;
%include iocbx;
%page;
%include iom_pcw;
%page;
%include iom_dcw;
%page;
%include rcp_disk_info;
%page;
%include iox_modes;
%page;
%include fs_dev_types;
%page;
%include query_info;


     end exercise_disk;




		    fdisk_status_table_.alm         10/21/92  1557.6rew 10/21/92  1550.5       38574



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

" HISTORY COMMENTS:
"  1) change(92-10-02,WAAnderson), approve(92-10-02,MCR8276),
"     audit(92-10-14,Vu), install(92-10-21,MR12.5-1037):
"     This new ALM status table provides the proper status to message
"     conversions required by FIPS disk devices.
"                                                      END HISTORY COMMENTS

include	status_table


" 

	status_table	fdisk,(1,1,1,1,1,1,0,0,1,0,1,1,0,1,0,0,1,1,1,1,1,1,1,1)

" 

	status_entry	1,(Channel Ready)

	substat_entry	1,000000,,(No substatus)
	substat_entry	1,000001,,(Retried 1 time)
	substat_entry	1,000010,,(Retried 2 times)
	substat_entry	1,000011,,(Retried 3 times)
	substat_entry	1,0010XX,,(Device in T&D)
	substat_entry	1,010000,,(EDAC correction performed)

" 

	status_entry	2,(Device Busy)

	substat_entry	2,000000,bk+rp,(Device positioning)
	substat_entry	2,100000,bk+rp,(Alternate channel in control)

" 

	status_entry	3,(Device Attention)

	substat_entry	3,000001,rp+hlt,(Write inhibited)
	substat_entry	3,000010,rp+hlt,(Seek incomplete)
	substat_entry	3,001000,rp+hlt,(Device fault)
	substat_entry	3,010000,rp+hlt,(Device in standby)
	substat_entry	3,100000,rp+hlt,(Device offline)

" 

	status_entry	4,(Device Data Alert)

	substat_entry	4,000001,bk+rp,(Transfer timing alert)
	substat_entry	4,000010,bk+rp,(Transmission parity alert)
	substat_entry	4,000100,rp+hlt,(Invalid seek address)
	substat_entry	4,0X1000,bk+rp,(Header verification failure)
	substat_entry	4,X1X000,bk+rp,(Check character alert)
	substat_entry	4,1X0000,bk+rp,(Compare alert)

" 

	status_entry	5,(End of File)

	substat_entry	5,000000,bk+rp,(Good track detected)
	substat_entry	5,0000X1,bk+rp,(Last consecutive block)
	substat_entry	5,00001X,bk+rp,(Sector count limit exceeded)
	substat_entry	5,000100,rp,(Defective trk-alternate assnd)
	substat_entry	5,001000,rp,(Defective trk-no alternate assnd)
	substat_entry	5,010000,rp,(Alternate track detected)

" 

	status_entry	6,(Command Reject)

	substat_entry	6,000001,rp+hlt,(Invalid operation code)
	substat_entry	6,000010,rp+hlt,(Invalid device code)
	substat_entry	6,001000,rp+hlt,(Invalid instruction sequence)

" 

	status_entry	9,(Channel busy)


" 

	status_entry	11,(IPC-FIPS Dev Attn)

	substat_entry	11,000010,rp+hlt,(Multiple devices)
	substat_entry	11,000011,bk+rp,(Illegal device number)
	substat_entry	11,001011,rp,(Usage/Error Stat Overflow)

" 

	status_entry	12,(IPC-FIPS Dev Data Alert)

	substat_entry	12,010001,bk+rp,(Sector size error)
	substat_entry	12,010010,rp+hlt,(Nonstandard sector size)
	substat_entry	12,010011,rp+hlt,(Search alert (first search))
	substat_entry	12,010100,rp+hlt,(Cyclic code error)
	substat_entry	12,010101,rp+hlt,(Search error (not first search))
	substat_entry	12,010111,rp+hlt,(Error in alternate track)
	substat_entry	12,100001,rp+hlt,(Write buffer parity)
	substat_entry	12,100010,bk+rp,(Uncorrectable read)
" 

	status_entry	14,(IPC-FIPS Command Reject)

	substat_entry	14,000001,rp+hlt,(Illegal op-code)

	status_entry	17,(Power Off);

	status_entry	18,(Channel Status);
	substat_entry	18,001000,rp+hlt,(Connect while busy);
	substat_entry	18,010000,rp+hlt,(Illegal channel inst);
	substat_entry	18,011000,rp+hlt,(Incorrect DCW);
	substat_entry	18,100000,rp+hlt,(Incomplete inst. seq.);
	substat_entry	18,110000,rp+hlt,(PSI parity error);
	substat_entry	18,111000,rp+hlt,(Parity err, I/O bus to chan);

	status_entry	19,(Central Status);
	substat_entry	19,111000,rp+hlt,(Parity err, I/O bus from chan);

	status_entry	20,(I/O System Fault);

	status_entry	21,(Non-zero Tally Residue);

	status_entry	22,(Auto Retries);

	status_entry	23,(EDAC Performed);

	status_entry	24,(Data Parity);
	
	end




		    format_disk_pack.pl1            07/20/88  1301.0r w 07/19/88  1535.0      477162



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


format_disk_pack:  fdp:	procedure;

/*
   Initially coded by J. A. Bush -- December, 1975
   Modified by J. A. Bush -- May 1976 for NSS to write format label on System volumes
   Modified by J. A. Bush -- July 1977 to fix bug making t.i. bits undefined if "-hbypass" and "-nodef" args were both used
   Modified by P. B. Kelley -- August 1978 to fix several bugs and remove dependence upon rec. 7 of Multics label.
			 Entire volume bad track list may now only be generated by "read_pack" & "format_pack" ops.
			 Changed structure of arguments passed to avoid "positional argument bugs".
			 Also provided consistency and constraints for formatting tracks.
*/

% include disk_pack;
% include fs_vol_label;

%include query_info;

dcl  iox_$attach_name	entry (char (*), ptr, char (*), ptr, fixed bin (35)),
     iox_$close		entry (ptr, fixed bin (35)),
     iox_$control		entry (ptr, char (*), ptr, fixed bin (35)),
     iox_$detach_iocb	entry (ptr, fixed bin (35)),
     iox_$modes		entry (ptr, char (*), char (*), fixed bin (35)),
     iox_$open		entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
     iox_$seek_key		entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)),
     iox_$read_record	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     iox_$rewrite_record	entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
    (ioa_, com_err_, ioa_$rsnnl, command_query_)	entry options (variable),
     cv_dec_check_		entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     get_system_free_area_	entry returns (ptr),
     hcs_$initiate		entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
     hcs_$fs_get_mode	entry (ptr, fixed bin (5), fixed bin (35)),
     cu_$arg_count		entry (fixed bin),
     cu_$arg_ptr		entry (fixed bin, ptr, fixed bin, fixed bin (35)),
     user_info_$process_type	entry ( fixed bin ),
     date_time_		entry (fixed bin (71), char (*));

dcl 1 trk_header_info aligned,			/* structure returned from rd_trk_header order */
    2 ha_cyl bit (16) unaligned,			/* home address cylinder number */
    2 ha_hd bit (16) unaligned,			/* home address head number */
    2 pad1 bit (2) unaligned,
    2 ti bit (2) unaligned,				/* track indicator bits */
    2 pad2 bit (10) unaligned,
    2 r0cti bit (2) unaligned,			/* record zero ti bits */
    2 r0ccyl bit (16) unaligned,			/* record zero count cylinder number */
    2 r0chd bit (16) unaligned,			/* record zero count head number */
    2 r0crn bit (8) unaligned,			/* record zero count  record number */
    2 pad3 bit (24) unaligned,
    2 r0df (8) bit (8) unaligned,			/* record zero data field */
    2 pad4 bit (4) unaligned;

dcl 1 fmt_info aligned,				/* user supplied structure for format_trk order */
    2 hz bit (2) unaligned,				/* header bypass information */
    2 ti bit (2) unaligned,				/* track indicator bits */
    2 alt_def_cyl fixed bin (16) unaligned,		/*  user supplied cyl and head address for alt or   */
    2 alt_def_hd fixed bin (16) unaligned;		/* defective track address */

dcl 1 dev_char_table aligned,				/* return structure from device_info order */
    2 subsystem_name char (4),			/* Disk subsystem name */
    2 device_name char (8),				/* Disk drive name */
    2 sect_per_dev fixed bin (35),			/* total no. of non-T&D sectors on pack */
    2 cyl_per_dev fixed bin,				/* no. of non-T&D cylinders on pack */
    2 sect_per_cyl fixed bin,				/* no of sectors per cylinder */
    2 sect_per_track fixed bin,			/* no. of sectors per track */
    2 num_label_sect fixed bin,			/* no. of sectors to reserve for label */
    2 num_alt_sect fixed bin,				/* no. of sectors to reserve for alt. track area */
    2 sect_size fixed bin (12);			/* no. of words in sector */

dcl 1 bounds,					/* return structure from getbounds order */
    2 low fixed bin (35),				/* low boundary */
    2 high fixed bin (35);				/* high disk boundary */

dcl (error_table_$noarg,
     error_table_$action_not_performed,
     error_table_$not_detached,
     error_table_$request_not_recognized) ext fixed bin (35);

dcl (code, seek_key, alt_add) fixed bin (35);
dcl  process_type fixed bin;
dcl ( ap, iocb_ptr, lsp, query_ptr ) ptr;
dcl  areap ptr;
dcl  formatp ptr;					/* pointer to format_label structure */
dcl (mode, i, j, cyl, head, line_pos, outlen, altb, rlen, legal_cyl, legal_hd) fixed bin;
dcl (al, n_args, sect_per_rec, use_sect_per_cyl, unuse_sect_per_cyl) fixed bin;
dcl  arg char (al) based (ap);
dcl  rec_len fixed bin (21);

dcl  rs_mode fixed bin (5);				/* rcp_sys_ acess mode */
dcl  execute bit (5) init ("00100"b);			/* execute permission */
dcl  Option	char (20) varying,
     answer	char (10) varying,
     erresponse	char (18) varying,
     response	char (18) varying,
     vol_id	char (32) varying;

dcl  adescrip	char (168),			/* rdisk_ attach description */
     dev_type	char (4),
     proc_name	char (16) init ("format_disk_pack"),
     pstring	char (5),
     ltime	char (24),
     out		char (256);
dcl  error label;
dcl  cleanup		condition,
     program_interrupt	condition;
dcl (already_printed, input, open, read, hold, defective, interactive, system, fmt_good, bypass, priv, rstsw, fstsw,
     write_attach, not_attached_by_me)
     bit (1) unaligned init ("0"b);
dcl (addr, bit, ceil, divide, fixed, hbound, index, length, mod, null, rtrim, substr, verify) builtin;
dcl  (alt_partition_present, multics_storage_system_volume, total_bad_track_list) bit(1) init ("0"b);
dcl  RECURSE bit(1) static init ("0"b);

dcl  multics_lab_rec fixed bin(23) unaligned;
dcl  1  MULTICS_LABEL aligned like label;

dcl  area area based (areap);

dcl max_bad_trks fixed bin(35) init(141);		/* maximum number of bad tracks - initialize for now */

dcl 1 FORMAT_INFO aligned based (formatp),		/* format data - allocated in system free */
    2 bad_trk_count fixed bin,			/* Number of defective tracks on this pack */
    2 bad_trks (max_bad_trks),			/* array of defective tracks */
      3 track_addr fixed bin (35),			/* First bad Multics record address on this bad track */
      3 alt_addr   fixed bin(35),			/* alternate addr ( = 0 if none) */
      3 bad_rcd_cnt fixed bin;			/* number of bad Multics records on this track */


	if RECURSE then do;				/* don't allow recursive calling */
	     call com_err_ (error_table_$action_not_performed, proc_name,
		"^/^a cannot be invoked recursively. Please type ^/ release -all ^/and try again.", proc_name);
	     return;
	end;
	query_ptr = addr (query_info);
	call user_info_$process_type ( process_type );
	if process_type ^= 1
	     then interactive = "0"b;
	     else interactive = "1"b;
	multics_lab_rec = LABEL_ADDR;
	call cu_$arg_count (n_args);
	if n_args < 2 then do;			/* not enough or no args */
	     call com_err_ (error_table_$noarg, proc_name);
puse:
	     call com_err_ (0, "", "Usage:^-format_disk_pack operation <-volume volume_name> {-control_args-}" );
	     call com_err_ (0, "", "^-^2xoperation:^5xformat_pack, read_pack, format_track, read_track, or read_label" );
	     call com_err_ (0, "", "^-^2xcontrol_args:^2x<-model model_name>, -system, -nodef, -hold, -hbypass"   );
	     call com_err_ (0, "", "^-^5xmodel_name may be: m451, m400, d190, or d181 (m400 default)");

	     return;
	end;
	vol_id = "";				/* initialize to check */
	dev_type = "m400";				/* default  */

	do i = 1 to n_args;				/* process arguments */
	     call cu_$arg_ptr (i, ap, al, code);
	     if code ^= 0 then do;
		call com_err_ (code, proc_name);
		return;
		end;
	     if i = 1 then do;			/* special case arg 1 = positional arg = order */
		if ( (arg ^= "format_track") & (arg ^= "format_pack")
		   & (arg ^= "read_track") & (arg ^= "read_pack")
		     & (arg ^= "read_label") ) then do;
		     call com_err_ (error_table_$request_not_recognized, proc_name, "^a", arg );
		     return;
		     end;
		Option = arg;			/* got a valid Option */
						/* make sure Option doesn't require "interactive" */
		if (^interactive) then if ( (Option ^= "format_pack") & (Option ^= "read_pack") & (Option ^= "read_label") ) then do;
		     call com_err_ (0, proc_name, "The ""^a"" operation is valid only from an interactive process.", Option );
		     return;
		     end;
		end;

	     else if ((arg = "-volume") | (arg = "-vol")) then do;	/* volume" name comes next */
		i = i + 1;				/* increment i */
		call cu_$arg_ptr ( i, ap, al, code );
		if ( (code ^= 0) | (al = 0) ) then do;		/* need volume name */
		     call com_err_ ( 0, proc_name, "Missing volume name after the ""-volume"" control argument." );
		     return;
		     end;
		vol_id = arg;
		end;

	     else if arg = "-model" then do;			/* model comes next */
		i = i + 1;
		call cu_$arg_ptr( i, ap, al, code );
		if ( (code ^= 0) | (al = 0) ) then do;		/* need model # after "-model" */
		     call com_err_ ( 0, proc_name, "Missing model after the ""-model"" control argument." );
		     return;
		     end;
		dev_type = arg;				/* got device type */
		end;

	     else if ( (arg = "-system") | (arg = "-sys") ) 	/* thinks they have system privileges */
		then system = "1"b;				/* we'll check for sure later. */

	     else if arg = "-hold" then do;			/* user doesn't want to release disk */
		if ^interactive then do;			/* can't "hold" from absentee */
		     call com_err_ (0, proc_name, "The ""-hold"" argument is only allowed from an interactive process.");
		     return;
		     end;
		hold = "1"b;
		end;

	     else if arg = "-hbypass"				/* bypass track headers already there */
		then bypass = "1"b;

	     else if arg = "-nodef" then do;			/* no defective tracks */
		if Option ^= "format_pack" then do;		/* only valid with this order */
		     call com_err_ (0, proc_name,
			"The ""-nodef"" argument is only valid with the ""format_pack"" order." );
		     return;
		     end;
		fmt_good = "1"b;				/* passed the test */
		end;

	     else do;					/* must be illegal option */
		call com_err_ (error_table_$request_not_recognized, proc_name, "^a", arg);
		return;
		end;
	     end;

	if vol_id = "" then do;				/* user must specify volume name */
	     call com_err_ (0, proc_name, "No volume specified. Cannot perform operation." );
	     return;
	     end;
						/* Do we have to attach the disk for writing?	*/
	if (Option = "format_pack" | Option = "format_track" )
	     then write_attach = "1"b;		/* definitely!	*/
	if (fmt_good | hold | bypass)
	     then write_attach = "1"b;		/* likewise..	*/

	on cleanup call release;			/* set up "cleanup" handler to release pack.	*/
	call mount;				/* and make call to mount the disk */
	if (code ^= 0 | ^open) then do;		/* error?	*/
	     call release;			/* make sure we release before exiting */
	     return;				/* couldn't mount, reason already given */
	     end;

	go to find_op;

option_lp:
	if ^interactive | (interactive & ^hold) then do;	/* release disk pack */
	     call release;
	     return;
	     end;
	if ^already_printed then do;			/* only print out instructions once */
	     already_printed = "1"b;
	     call ioa_ ("After ""Options:"", is typed out, enter one of the following options:");
	     call ioa_ ("""format_pack"", ""read_pack"", ""read_track"", ""format_track"", ""read_label"", or ""quit""");
	     end;

	yes_or_no_sw, suppress_name_sw = "0"b;
	call command_query_ (query_ptr, Option, "", "Options:");
find_op:
	if Option = "format_pack"
	     then call format_pack;

	else if Option = "read_pack" then do;
	     call read_pack;
	     end;

	else if Option = "read_label" then do;
	     call read_pack_label;
	     end;

	else if Option = "read_track" then do;
	     if ^interactive then do;			/* operation is not allowed in absentee mode */
abs_err:		call com_err_ (0, proc_name, "The ^a operation is only allowed from an ""interactive"" process.", Option);
		return;
		end;
	     call read_track;
	     end;

	else if Option = "format_track" then do;
	     if ^interactive
		then go to abs_err;			/* operation is not allowed in absentee mode */
						/* if Multics & it has no alt part., then don't allow this */
	     if (multics_storage_system_volume & ^alt_partition_present) then do;
		call ioa_ ("Multics Storage System volume ""^a"" has no ""alt"" partition defined.",
		     vol_id );
		call ioa_ ( "The ""format_track"" operation is not valid on this volume." );
		go to option_lp;
		end;
	     call format_track;			/* OK, we'll allow it */
	     end;

	else if Option = "quit" then do;
	     if open
		then call release;			/* dismount pack if mounted */
	     return;
	     end;

	else if ^already_printed then do;			/* if  the initial entry */
	     call com_err_ (0, proc_name, "Operation ^a not recognized", Option);
	     go to puse;
	     end;

	else call com_err_ (0, proc_name, "Illegal option ^a, reenter", Option);
	go to option_lp;

read_pack: proc;					/* read_pack subsystem */

				/* Forms seek addresses for the entire pack, then calls	*/
				/* the rd_sing_trk proc to process. Summary only at end.	*/
	     call ioa_ ("Begin ""read_pack"" operation");
						/* since this operation takes a long time */
						/* establish pi handler to say something  */
	     on program_interrupt			/* useful if user gets bored.              */
		call ioa_ ("Processing ^a", cseek (seek_key ) );

	     do seek_key = bounds.low to bounds.high - sect_per_track by sect_per_track;
		call rd_sing_trk (seek_key);		/* rd track header */
		if code ^= 0
		     then call com_err_ (0, proc_name, "Skipping to next track.");
		end;

	     revert program_interrupt;

						/* if we got this far then we've got the */
	     total_bad_track_list = "1"b;		/* total bad track list figured out.  */
						/* if we had any bad tracks  print them out */
	     call prt_bad_trks;

	     return;

	end read_pack;

read_track:  proc;					/* read track subsystem */

				/* Queries user for "ccc,hh" input, then calls the 	*/
				/* rd_sing_trk proc to process and print.		*/

	if ^rstsw then do;				/* print out instructions one time */
	     call ioa_ ("Enter track address as ""ccc,hh"" for cylinder and head");
	     call ioa_ ("Terminate query by typing ""quit"".");
	     rstsw = "1"b;			     	/* set switch so we don't print this out  again */
	     end;

	input = "1"b;
	do while (input);
read_track_er:
	     yes_or_no_sw = "0"b;
	     suppress_name_sw = "1"b;
	     call command_query_ (query_ptr, response, "", "Enter:");
	     if ( (response = "quit") | (length(response) = 0) ) then do;
		input = "0"b;
		call prt_bad_trks;			/* print out what we know */
		end;
	     else do;				/* still in the loop */
		erresponse = response;		/* save for error reporting */
		error = read_track_er;		/* set up error label */
		line_pos = 1;			/* start at beginning of input */
		rlen = length(response);		/* initial string length */
		seek_key = form_sk_add ();		/* convert address */
		call rd_sing_trk (seek_key);		/* call reader */
		end;
	     end;

	end read_track;

rd_sing_trk: proc (seek_key);				/* procedure to read headers of single trks */

				/* Makes call to rd_header to physically read track.	*/
				/* If called from the "read_track" option, then full	*/
				/* description of track's status is printed, otherwise,	*/
				/* only errors in track assignment are printed.		*/
				/* If the track is "defa" or "alt", then an attempt is	*/
				/* made to read the track which it points to for		*/
				/* verification. If this verification turns out false, then	*/
				/* user is warned appropriately.			*/

dcl
     seek_key	fixed bin(35),
     temp_seek_key	fixed bin(35),
     match_seek_key	fixed bin(35);


	call rd_header (seek_key);			/* go read the header */
	if code ^= 0
	     then return;				/* if error skip to next trk */

	if trk_header_info.ti = "00"b then do;		/* "good", form message for later */
		call ioa_$rsnnl ("Track ^a is formatted ""good"".", out, outlen, cseek(seek_key) );
		call remove (seek_key);		/* make sure it's out of def list */
		end;

	else if trk_header_info.ti = "11"b then do;	/* "def", form message for later  */
		call ioa_$rsnnl ("Track ^a is formatted ""def"", no alternate assigned.", out, outlen, cseek(seek_key) );
		call sort (seek_key, 0);		/* sort into defective list */
		end;

	else if trk_header_info.ti = "01"b then do;	/* alternate trk */
	     call remove (seek_key);			/* make sure it's out of def. list */
	     error = rd_sing_loop;
	     temp_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
						/* form message for later */
	     call ioa_$rsnnl ("Track ^a is formatted alternate for defective track ^a",
		out, outlen, cseek(seek_key), cseek(temp_seek_key) );
	     call rd_header (temp_seek_key);
	     if code ^= 0 then do;
						/* add to previous message for later */
		call ioa_$rsnnl ("^/Unable to verify original defective track.  ^a.",
		     out, outlen, cseek ( temp_seek_key) );
		go to rd_sing_loop;
		end;
						/* match defective and its assigned alt */
	     match_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
	     if match_seek_key ^= seek_key then do;	/* shouldn't be this way !! */
		call ioa_ ( "^/ERROR: Assignment mismatch.^/^a",
		     "Defective track and its alleged alternate do not agree." );
		call ioa_ ("Track ^a has been assigned as alternate for ^a,",
		     cseek (seek_key), cseek(temp_seek_key) );
		call ioa_ ("while ^a doesn't think ^a is its alternate.",
		     cseek(temp_seek_key), cseek(seek_key) );
		return;				/* return from here */
		end;
	     call sort (temp_seek_key, seek_key);		/* sort in original trk */
	     end;

	else if trk_header_info.ti = "10"b then do;	/* "defa" */
	     call sort (seek_key, 0);			/* sort into defective list */
	     error = rd_sing_loop;
	     temp_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
						/* form message for later */
	     call ioa_$rsnnl ("Track ^a is formatted defective, alternate track assigned - ^a",
		out, outlen, cseek(seek_key), cseek(temp_seek_key) );
	     call rd_header (temp_seek_key);		/* read alternate */
	     if code ^= 0 then do;
						/* add to previously formed message */
		call ioa_$rsnnl ("^/Unable to verify assigned alternate.  ^a",
		     out, outlen, cseek(seek_key) );
		go to rd_sing_loop;
		end;
	     match_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
	     if match_seek_key ^= seek_key then do;	/* this shouldn't happen */
		call ioa_ ( "ERROR: Assignment mismatch. Defective track and its assigned alternate do not match." );
		call ioa_ ("Track ^a has been formatted as defective with ^a as its assigned alternate.",
		     cseek(seek_key), cseek(temp_seek_key) );
		call ioa_ ("while ^a doesn't think its the alternate for ^a",
		     cseek(temp_seek_key), cseek(seek_key) );
		call ioa_ ("This is a serious discrepency and must be fixed before using disk.");
		return;				/* return from here */
		end;
	     call remove (seek_key);			/* we've already put it in without its alt , so */
	     call sort (seek_key, temp_seek_key);	/* sort in def and it's alt */
	     end;
rd_sing_loop:
	if Option = "read_track"			/* if we're in verbose mode, then */
	     then call ioa_ ("^a", out);		/* print out something */
	return;

	end rd_sing_trk;

format_pack: proc;					/* read pack and format pack subsystems */

				/* Forms seek address for entire pack then calls		*/
				/* format_trk for actual formating. If the "-nodef"	*/
				/* or "-hbypass" control argument was given, then previous	*/
				/* track info is ignored. Otherwise, the track is		*/
				/* first read and if "def", "defa", or "alt", then its	*/
				/* previous info is retained.				*/

	if (fmt_good | bypass) then do;		/* warn user */
	     call ioa_ ("^/Warning:  The ""-nodef"" and/or ""-hbypass"" control argument being specified,");
	     call ioa_ ("^-previous bad track information will be ignored.");
	     end;

	call ioa_ ("Begin ""format_pack"" operation");
						/* since this operation takes a long time */
						/* establish pi handler to say something  */
	on program_interrupt			/* useful if user gets bored.        */
	     call ioa_ ( "Processing ^a", cseek (seek_key) );

	if bypass
	     then fmt_info.hz = "00"b;		/* set up header bypass switch */
	     else fmt_info.hz = "01"b;
	FORMAT_INFO.bad_trk_count = 0;		/* initialize bad track counter */

	do seek_key = bounds.low to bounds.high - sect_per_track by sect_per_track;
	     fmt_info.ti = "00"b;			/* initially set ti bits for good trk */
	     fmt_info.alt_def_cyl = 0;		/* zap alt information */
	     fmt_info.alt_def_hd = 0;
	     if ^( bypass | fmt_good ) then do;		/* if we're not ignoring previous info */
		call rd_header (seek_key);		/* rd track header */
		if code ^= 0
		     then go to format_pack_er1;	 /* skip read on error, but try write */
		if trk_header_info.ti ^= "00"b then do;
		     fmt_info.ti = trk_header_info.ti;
		     fmt_info.alt_def_cyl = fixed(trk_header_info.r0ccyl);
		     fmt_info.alt_def_hd = fixed(trk_header_info.r0chd);
		     if trk_header_info.ti ^= "01"b	/* don't sort in "alt"'s */
			then call sort (seek_key, 0);		/* initially sort in as "def" */
		     if trk_header_info.ti = "10"b then do;	/* if "defa", then get alt */
			call remove (seek_key);
			call rd_sing_trk (seek_key);		/* this verifies, plus sorts in addr */
			end;
		     end;
		end;
format_pack_er1:
	     call format_trk (seek_key);		/* go format */
	     if code ^= 0
		then call com_err_ (0, proc_name, "Skipping to next track.");
	     end;
	revert program_interrupt;
						/* if we got this far then we've got the */
	total_bad_track_list = "1"b;			/* total bad track list figured out.     */
						/* if we had any bad tracks  print them out */
	call prt_bad_trks;
	return;
	end format_pack;

format_track: proc;				/* format_track subsystem			*/
					/* Queries user for cyl/head and status of track.	*/
					/* Calls fmt_sing_trk to do the actual formatting.*/
dcl  info bit(2) aligned;

	if (fmt_good | bypass) then do;		/* warn user */
	     call ioa_ ("^/Warning:  The ""-nodef"" and/or ""-hbypass"" control argument being specified,");
	     call ioa_ ("^-previous bad track information will be ignored.");
	     end;

	if ^fstsw then do;				/* print out instructions one time */
	     call ioa_ ("Enter tracks to be formatted as:^/  ""ccc,hh,good"" - for a good track");
	     call ioa_ ("  ""ccc,hh,def""  - for a defective track with no alternate assigned");
	     call ioa_ ("  ""ccc,hh,defa"" - for a defective track, alternate assigned");
	     call ioa_ ("Terminate query by typing ""quit"".");
	     fstsw = "1"b;				/* set switch so we don't print this out again */
	     end;

	input = "1"b;				/* make sure we go thru loop at least once */
	if bypass
	     then fmt_info.hz = "00"b;		/* set up header bypass switch */
	     else fmt_info.hz = "01"b;

	     do while (input);
fmt_loop_er1:					/* error label */
		yes_or_no_sw = "0"b;
		suppress_name_sw = "1"b;
		call command_query_ (query_ptr, response, "", "Enter:");
		if ( (response = "quit" ) | ( length (response) = 0 ) ) then do;
		     input = "0"b;			/* terminate query */
		     call prt_bad_trks;		/* print out the bad trk list */
		     end;
		else do;
		     erresponse = response;		/* save reponse for error reporting */
		     line_pos = 1;			/* start at the beginning of input */
		     rlen = length (response);	/* set up initial string length */
		     error = fmt_loop_er1;		/* set up error return label */
		     seek_key = form_sk_add ();	/* convert address */
		     pstring = parse ();		/* get type of format */

		     if pstring = "good"		/* check out action */
			then info = "00"b;		/* and set appropriate bit */
		     else if pstring = "defa"
			then info = "10"b;
		     else if pstring = "def"
			then info = "11"b;
		     else do;			/* none of the above ?? */
			call ioa_ ("Error in input parameters - ""^a"", please reenter.", erresponse );
			go to fmt_loop_er1;
			end;
		     call fmt_sing_trk(seek_key, info);	/* make call to fmt routine */
		     end;
fmt_sing_loop:
		end;
	end format_track;

fmt_sing_trk: proc ( seek_key, info );			/* procedure to format single tracks */

	/*  .................................................................................... 	*/
	/*									*/
	/*  The heart of the formatting routine.  Called by format_track subsystem.		*/
	/*  Rules:								*/
	/*     1) If the track is to be formatted as "good":				*/
	/*	If currently "good" or "def", then re-format it.				*/
	/*	If currently "defa", then re-format this track and its alternate as well.	*/
	/*	If currently "alt",  then don't re-format. User must re-format original first.	*/
	/*     2) If the track is to formatted as "def":					*/
	/*	If currently "good", or "def", then re-format it.				*/
	/*	If currently "defa", then user must re-format track as "good" first.		*/
	/*	If currently "alt",  then user must re-format original track first.		*/
	/*     3) If track is to formatted as "defa":					*/
	/*	If currently "good" or "def", then re-format and assign alternate.		*/
	/*	If currently "defa" or "alt", then report state and return.			*/
	/*     4) Tracks within the ALT partition may not be formatted as "defa".		*/
	/*     5) The T & D cylinder may be formatted with this command for test purposes, or	*/
	/*	for curiosity. However, it's presence is not mentioned when the cylinder	*/
	/*	range is listed, nor are these tracks used as possible alternate tracks.	*/
	/*	Those more informed will know what it's for.				*/
	/*  .................................................................................... 	*/

dcl
     seek_key	fixed bin(35),			/* input seek address */
     info		bit(2) aligned,			/* bits corresponding to format request */
     temp_seek_key	fixed bin(35),			/* temporary seek address */
     match_seek_key	fixed bin(35);			/* used for matching */

	code = 0;
	fmt_info.alt_def_cyl = 0;			/* initialize for now	*/
	fmt_info.alt_def_hd  = 0;
/* +++++++++++ */
/* good & def  */
/* +++++++++++ */
	if ( (info = "00"b) | (info = "11"b) ) then do;	/* same code for "good" & "def" */
	     call rd_header(seek_key);		/* read what's already there */
	     if code = 0 then do;			/* if we can read what's there then lets look at it */
						/* if we couldn't read, then branch to format section */
		if trk_header_info.ti = "00"b		/* if already "good", say nothing but proceed to */
		     then;			/* re-format it anyway   */

		else if trk_header_info.ti = "11"b	/* if previously "def" then do nothing proceed to */
		     then;			/* to format it anyway */

		else if trk_header_info.ti = "10"b then do;/* if previously "defa" then check it out */
		     error = fmt_sing_er2;		/* set up return label */
		     temp_seek_key = form_address( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
		     call rd_header(temp_seek_key);	/* read assigned alt to check */
		     if code ^= 0			/* got error reading, so skip this */
			then go to fmt_sing_er2;
		     if trk_header_info.ti = "01"b then do;	/* yup, was assigned alt trk */
			error = fmt_sing_er2;		/* if not valid address then ignore */
			match_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
							/* try for match against original address */
			if seek_key = match_seek_key then do;	/* MATCH, therefore must decide */
							/* if trying to format as "def", then force */
							/* user to re-format track "good" first */
			     if info = "11"b then do;
				call remove ( seek_key );
				call sort (seek_key, temp_seek_key);
				call ioa_ ("This track is currently formatted ""defa"" with ^a assigned alternate.",
				     cseek(temp_seek_key) );
				call ioa_ ("Track ^a must be re-formatted as ""good"" before formatting as ""def"".",
				     cseek(seek_key) );
				call ioa_ ("Track has not been modified." );
				return;
				end;

			     fmt_info.ti = "00"b;			/* set up for "good" */
			     call format_trk (temp_seek_key);		/* format alt as good */
			     if code ^= 0
				then go to fmt_sing_er2;
			     call remove (seek_key);
			     call ioa_ ("Previously assigned alternate track ^a formatted as ""good"".",
				cseek(temp_seek_key) );
			     end;
			end;
		     end;
		else if trk_header_info.ti = "01"b then do;	/* if previously "alt" then check it out */
		     error = fmt_sing_er2;			/* set up return label */
		     temp_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
		     call rd_header(temp_seek_key);		/* read original track to check */
		     if code ^= 0				/* got error reading, so skip this */
			then go to fmt_sing_er2;		/* allow user to format track */
		     if trk_header_info.ti = "10"b then do;	/* yup, it's really "defa" */
			match_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
							/* try for match against original address */
			if seek_key = match_seek_key then do;	/* MATCH */
							/* the user  must format orig. trk not this alt */
			     call sort (temp_seek_key, seek_key);	/* sort in original trk */
			     call ioa_ ("This track is formatted as the alternate for ^a.", cseek(temp_seek_key));
			     call ioa_ ("Original track ^a must be re-formatted first.", cseek(temp_seek_key) );
			     call ioa_ ("Track has not been modified." );
			     return;
			     end;
			end;
		     end;
		end;
fmt_sing_er2:
	     fmt_info.ti = info;			/* set ti bits to appropriate value */
	     call remove (seek_key);			/* remove this trk from the bad trk list */
	     call format_trk (seek_key);		/* format track */
	     if code ^= 0 then do;
		call ioa_ ("Unable to format requested track.");
		call ioa_ ("Track ^a not modified.", cseek(seek_key) );
		return;
		end;
	     if info = "00"b			/* spout appropriate message */
		then call ioa_ ("Track ^a formatted ""good"".", cseek(seek_key) );
		else do;
		     call ioa_ ("Track ^a formatted ""def"".", cseek(seek_key) );
		     call sort (seek_key, 0);
		     end;
	     end;

/* ++++ */
/* defa */
/* ++++ */
	else if info = "10"b then do;			/* "defa" */
	     if seek_key ^< altb then do;		/* check to make sure we aren't assigning an alternate */
						/* for an alternate. It just doesn't seem right */
		call ioa_ ("This track is within the ""alt"" partition. These tracks may not be formatted as ""defa""." );
		call ioa_ ("Track has not been modified."  );
		return;
		end;
	     call rd_header (seek_key);		/* first, read what's already there */
	     if code = 0 then do;			/* if no error, then check it out */
		if trk_header_info.ti = "00"b		/* if "good", then do nothing here */
		     then;			/* but re-format it later on */

		else if trk_header_info.ti = "11"b	/* if "def", then do nothing */
		     then;			/* but re-format it later */

		else if trk_header_info.ti = "10"b then do;	/* it's already "defa" !! */
							/* since it's already "defa", we don't want */
							/* re-format it if it's a valid assignment. */
		     temp_seek_key = form_address ( (fixed(trk_header_info.r0ccyl)), (fixed(trk_header_info.r0chd)) );
		     call rd_header (temp_seek_key);
		     if code ^= 0
			then go to fmt_sing_er3;		/* ignore what it might have been */
		     if trk_header_info.ti = "01"b then do;	/* it checks so far */
							/* let's print out what we're up to */
			call ioa_ ("This track is already formatted ""defa"" with ^a assigned alternate.",
			     cseek (temp_seek_key) );
			call ioa_ ("Track has not been modified.");
			return;
			end;
		     end;
		end;
fmt_sing_er3:
						/* find first free alternate trk */
	     trk_header_info.ti = "01"b;		/* make sure we go thru loop once */
	     do alt_add = altb to sect_per_dev by sect_per_track while (trk_header_info.ti = "01"b);
		call rd_header (alt_add);
		if code ^= 0
		     then return;
		end;

	     alt_add = alt_add - sect_per_track;	/* subtract 1 track's worth (do loop tells 1 too many */

						/* important, check for legal address. (note >= */
	     if ( alt_add >= sect_per_dev ) then do;
		call ioa_ ("All alternates have been assigned, cannot format track as ""defa""." );
		call ioa_ ("Track ^a has not been modified.", cseek(seek_key) );
		return;
		end;

						/* format alternate trk first */

	     fmt_info.ti = "01"b;
	     fmt_info.alt_def_cyl = rcyl(seek_key);
	     fmt_info.alt_def_hd = rhead(seek_key);
	     call format_trk (alt_add);		/* format the alternate trk */
	     if code ^= 0 then do;			/* didn't work */
		call ioa_ ("Unable to assign alternate. Requested track not formatted." );
		return;				/* skip track on error */
		end;
	     call remove (alt_add);			/* remove alternate trk from defective list if present */

	     fmt_info.ti = "10"b;			/* set ti bits for def alt assigned */
	     fmt_info.alt_def_cyl = rcyl(alt_add);
	     fmt_info.alt_def_hd  = rhead(alt_add);
	     call format_trk (seek_key);		/* format requested track */
	     if code ^= 0 then do;			/* oh oh... */
		call ioa_ ("Unable to format requested track. Track has not been modified.");
		fmt_info.ti = "00"b;		/* set ti bits to "good" */
		fmt_info.alt_def_cyl = 0;
		fmt_info.alt_def_hd  = 0;
		call format_trk (alt_add);		 /* re-assign the alt as "good" */
		if code ^= 0 then do;		/* whoops, blew the alternate... */
		     call ioa_ ("Unable to re-assign the alternate track as ""good"".");
		     return;
		     end;
		return;
		end;
	     call sort (seek_key, alt_add);		/* sort in the defective address */
	     call ioa_ ("Track ^a formatted ""defa"" with alternate track ^a assigned.",
		cseek(seek_key), cseek (alt_add) );
	     end;


	end fmt_sing_trk;

rd_header: proc (sk_add);
						/* procedure to execute the rd_trk_header control */
						/* order and do appropriate error processing */
dcl  sk_add fixed bin (35);				/* IN  = seek address */

rd_header_er:
	     call iox_$seek_key (iocb_ptr, asc (sk_add), rec_len, code);
	     call iox_$control (iocb_ptr, "rd_trk_header", addr (trk_header_info), code);
	     if code ^= 0 then do;
		call com_err_ (code, proc_name);	/* report error */
		call com_err_ (0, "", "^-While executing a rd_trk_header command on ^a",
		     cseek (sk_add));
		if interactive then do;
		     yes_or_no_sw = "1"b;
		     suppress_name_sw = "0"b;
		     call command_query_ (query_ptr, answer, "", "Do you wish to try again?");
		     if answer = "yes" then go to rd_header_er;
		     else return;			/* let caller decide */
		     end;
		end;

	end rd_header;

format_trk: proc (sk_add);
						/* procedure to execute the format_trk order */
						/* and do appropriate error processing */
dcl  sk_add fixed bin (35);				/* IN  = seek address */
dcl  save_hz bit (2) unaligned;
dcl  er_sw bit (1) unaligned;

	     er_sw = "0"b;				/* reset error switch if set */
format_trk_er:
	     call iox_$seek_key (iocb_ptr, asc (sk_add), rec_len, code);
	     call iox_$control (iocb_ptr, "format_trk", addr (fmt_info), code);
	     if code ^= 0 then do;
		call com_err_ (code, proc_name);	/* report error */
		call com_err_ (0, proc_name, "while executing a format_trk cmd on ^a",
		     cseek (sk_add));
		if interactive then do;
		     yes_or_no_sw = "1"b;
		     suppress_name_sw = "0"b;
		     call command_query_ (query_ptr, answer, "", "Do you wish to try again?");
		     if answer = "yes" then do;
			if ^er_sw then do;		/* do not wipe out orig hz bits */
			     save_hz = fmt_info.hz;	/* save users header bypass switch */
			     fmt_info.hz = "00"b;	/* set them for header bypass */
			     er_sw = "1"b;		/* set er_sw */
			     end;
			go to format_trk_er;
			end;
		     else return;			/* let caller decide */
		     end;
		end;

	     if er_sw
		then fmt_info.hz = save_hz;		/* if we had an error restore org. bypass sw */

	end format_trk;

mount:	proc;					/* procedure to attach a disk pack */

	if write_attach
	     then mode = 13;			/* Mode = direct update */
	     else mode = 11;			/* for reading only. *
						/* dev_type previously determined */
	     if system then do;			/* check users access to rcp_sys_ */
		call hcs_$initiate (">system_library_1", "rcp_sys_", "", 0, 0, lsp, code);
		if lsp ^= null then do;		/* if can be initiated */
		     call hcs_$fs_get_mode (lsp, rs_mode, code); /* check caller's access */
		     if code = 0
			then if (bit (rs_mode) & execute )
			     then priv = "1"b;
		     end;
		end;
						/* build attach description */

	     call ioa_$rsnnl ("rdisk_ ^a ^a", adescrip, i, dev_type, vol_id); /* set up constants */
	     if write_attach				/* if we have to write on disk */
		then call ioa_$rsnnl ("^a  -write", adescrip, i, adescrip );
	     if priv
		then call ioa_$rsnnl ("^a -sys", adescrip, i, adescrip); /* if user has system priv. */
	     call ioa_$rsnnl ("^a -size 4096", adescrip, i, adescrip);

						/* attach rdisk_ */
	     if write_attach
		then call ioa_ ("Mounting disk ^a for writing", vol_id);
		else call ioa_ ("Mounting disk ^a for reading", vol_id);
	     call iox_$attach_name ("fmt_io_switch", iocb_ptr, adescrip, null, code);
	     if code ^= 0 then do;
		if code ^= error_table_$not_detached then do;
		     call com_err_ ( code, proc_name, "Attempting to attach disk." );
		     return;
		     end;
		not_attached_by_me = "1"b;		/* remember that we didn't perform the attachment */
		end;

	     call iox_$open (iocb_ptr, mode, "0"b, code);	 /* open  the i/o switch */
	     if code ^= 0 then do;
		call com_err_ ( code, proc_name, "Attempting to open disk I/O switch." );
		return;
		end;
	     open = "1"b;				/* indicate we are now attached to a device */
	     call iox_$modes (iocb_ptr, "raw", "", code); /* put dim in the raw mode */
	     call iox_$control (iocb_ptr, "getbounds", addr (bounds), code); /* get sector bounds of pack */
	     call iox_$control (iocb_ptr, "device_info", addr (dev_char_table), code); /*  and device char */

	     if not_attached_by_me
		then call ioa_ ("Using pack ^a already mounted on ^a ^a.", vol_id, subsystem_name, device_name  );
		else call ioa_ ("Disk pack ^a mounted on ^a ^a", vol_id, subsystem_name, device_name);

	     legal_cyl = divide (bounds.high, sect_per_cyl, 17, 0) - 1; /* set up input limits for user */
	     legal_hd = divide (sect_per_cyl, sect_per_track, 17, 0) - 1;
	     sect_per_rec = 1024 / sect_size;
	     use_sect_per_cyl = divide (sect_per_cyl, sect_per_rec, 17, 0) * sect_per_rec;
	     unuse_sect_per_cyl = sect_per_cyl - use_sect_per_cyl;
	     altb = sect_per_dev - num_alt_sect;	/* compute beginning of alternate track area */

	areap = get_system_free_area_();
	max_bad_trks = (legal_cyl+1)*(legal_hd+1);
	allocate FORMAT_INFO in (area) set (formatp);
	FORMAT_INFO.bad_trk_count = 0;

	if Option ^= "read_label"			/* not if that's what we're doing anyway */
	     then call read_pack_label;		/* let's see what it is */
	code = 0;					/* if we got this far, it's mounted */

	end mount;


release:	proc;					/* procedure to close and detach the disk pack.  */

	RECURSE = "0"b;				/* reset recursion-checking switch */
	     if ^open
		then return;
	     call iox_$close        (iocb_ptr, code);	/* close the i/o switch */
	     open = "0"b;				/* reset open switch */

	     if formatp ^= null then do;
		free FORMAT_INFO in (area);
		formatp = null;
		end;
	     if not_attached_by_me			/* don't detach if previously attached */
		then return;
	     call iox_$detach_iocb  (iocb_ptr, code);	/* detach the drive */

	end release;

						/* prt_bad_trks - procedure to print out the defective */
						/* trk, bad Multics record info contained in the       */
						/* temporary bad_trk_segment.  It does not print       */
						/* tracks previously formatted.                        */
prt_bad_trks: proc;

dcl (i, j, out_len) fixed bin;
dcl  out_str char (100);

	     if total_bad_track_list			/* if we know where the bad tracks are... */
		then call ioa_ ("^/Summary of bad tracks for entire volume ""^a"".", vol_id);
		else call ioa_ ("^/Summary of bad tracks formatted this session." );

	     if bad_trk_count ^= 0 then do;		/* found some bad tracks */
		call ioa_ ("^/Defective tracks    Bad Multics records^5x(alternate, if ""defa"")^/");
		do i = 1 to bad_trk_count;		/* print out the bad trks */
		     call ioa_$rsnnl ("^a", out_str, out_len, cseek ( bad_trks(i).track_addr));
		     do j = 0 to bad_trks(i).bad_rcd_cnt - 1;
			call ioa_$rsnnl ("^a  ^6d", out_str, out_len, out_str,
			     phy_mul ( bad_trks(i).track_addr + (j*sect_per_rec)));
			end;
		     if bad_trks(i).alt_addr ^= 0
			then if bad_trks(i).bad_rcd_cnt = 3	/* check for proper spacing...  */
			     then call ioa_$rsnnl ("^a^4x^a", out_str, out_len, out_str, cseek(bad_trks(i).alt_addr) );
			     else call ioa_$rsnnl ("^a^12x^a", out_str, out_len, out_str, cseek(bad_trks(i).alt_addr) );
		     call ioa_ ("^a", out_str);
		     end;
		call ioa_ ("");
		end;

		else call ioa_ ("No defective tracks found.");

	end prt_bad_trks;

cseek: proc (key) returns (char(18));			/* procedure to convert binary seek address */
						/* to ascii cyl and head number */
dcl  key fixed bin (35);				/* IN  = seek address */
dcl (cyl, head, len) fixed bin;
dcl  chstr char (18);

	     if key < sect_per_cyl
		then cyl = 0;
		else cyl = divide ( key, sect_per_cyl, 17, 0 );

	     len = mod (key, sect_per_cyl);
	     if len <= 0
		then head = 0;
		else head = divide ( len, sect_per_track, 17, 0 );

	     call ioa_$rsnnl ("cyl ^4d, head ^2d", chstr, len, cyl, head);
	     return ( chstr );

	end cseek;

phy_mul: proc (key) returns (fixed bin);		/* entry to return Multics record number */
						/* for a given seek address */
dcl  key fixed bin (35),				/* IN  = seek address */
     mrecord fixed bin;				/* OUT = Multics record number */

	     mrecord = divide ( key, sect_per_cyl, 17, 0 );
	     return ( divide ( key - mrecord, 16, 17, 0 ) );

	end phy_mul;

rhead: proc (key) returns (fixed bin);			/* entry to return head number in binary */

dcl  key fixed bin (35),				/* IN  = seek address */
     head fixed bin,				/* OUT = head number */
     len fixed bin;

	     len = mod (key, sect_per_cyl);

	     if len <= 0
		then head = 0;
		else head = divide ( len, sect_per_track, 17, 0 );
	     return ( head );			/* user only wants head number */

	     end rhead;

rcyl: proc (key) returns (fixed bin);			/* entry to return cyl number */

dcl  key		fixed bin (35);			/* IN  = seek address */
						/* RETURN = cyl number */

	if key < sect_per_cyl
	     then return (0);
	     else return ( (divide (key, sect_per_cyl, 17, 0) )  );

	end rcyl;

asc:	proc (key) returns (char (12) varying);
						/* internal procedure to convert fixed binary */
						/* seek address into zero filled char. string for rdisk_ */
dcl  key fixed bin (35);				/* IN  = seek address */
dcl  seek_pic picture "99999999";
dcl  v_string char (12) varying;

	     seek_pic = key;
	     v_string = seek_pic;
	     return (v_string);

	end asc;

mul_phy:	proc (r) returns (fixed bin (35));
						/* procedure to convert a Multics */
						/* record number to a binary seek address */
dcl  r fixed bin (23) unaligned;			/* IN  = Multics record number */
dcl  s fixed bin (35);				/* OUT = seek address */

	     s = r * sect_per_rec;
	     s = divide (s, use_sect_per_cyl, 17, 0) * unuse_sect_per_cyl + s;
	     return (s);

	end mul_phy;

form_sk_add: proc returns (fixed bin (35));
						/* procedure to pick up input parameters for cyl and head */
						/* and convert them to binary seek address */
dcl (int_sa, int_sb) fixed bin (37);
	     pstring = parse ();			/* get cylinder # */
	     cyl = cv_dec_check_ (pstring, code);
	     if code ^= 0 then do;
form_sk_add_er1:
		call ioa_ ("Error in input parameters - ""^a"", please reenter", erresponse);
		go to error;			/* return to label varable */
	     end;
	     if ((cyl > legal_cyl) | (cyl < 0)) then do;	/* illegal cyl number */
						/* pretend T&D cyl doesn't exist */
		call ioa_ ("Cylinder ^d illegal, cylinder range for this device is 0 to ^d", cyl, legal_cyl);
		go to error;
	     end;
	     pstring = parse ();			/* get head # */
	     head = cv_dec_check_ (pstring, code);
	     if code ^= 0 then go to form_sk_add_er1;
	     if ((head > legal_hd) | (head < 0)) then do;	/* illegal head number */
		call ioa_ ("Head ^d illegal, head range for this device is 0 to ^d", head, legal_hd);
		go to error;
	     end;
	     int_sa = cyl * sect_per_cyl;		/* compute raw cylinder number */
	     if int_sa > bounds.high then
		code = 1;				/* cyl # > # cylinders per device */
	     int_sb = head * sect_per_track;		/* compute raw head address */
	     if int_sb > sect_per_cyl then
		code = 2;				/* head # > heads per device */
	     int_sa = int_sa + int_sb;		/* compute full address */
	     if int_sa > bounds.high then
		code = 3;				/* total address > device capicity */
	     if code ^= 0 then go to form_sk_add_er1;
	     return (int_sa);
	end form_sk_add;

parse:	proc returns (char (*));
						/* procedure to parse input line and return individual args */
dcl  i fixed bin;
dcl  string char (10) varying;
	if rlen ^> 0 then do;			/* we're out of business */
	     string = "NOT";
	     return ( string );
	end;
	i = index (substr (response, line_pos, rlen), ",");
	if i = 0 then do;				/* either blank or last parameter */
	     if substr ( response, line_pos, rlen) ^= ""	/* last one...	*/
		then string = substr ( response, line_pos, rlen);
		else string = "NOT";
	     rlen = 0;
	     return ( string );
	end;
	string = substr (response, line_pos, i-1);
	line_pos = line_pos + i;
	rlen = rlen - i;
	return ( string );
	end parse;

form_address: proc ( cyl, head) returns (fixed bin (35));

dcl
     head		fixed bin,
     cyl		fixed bin;
dcl (int_sa, int_sb) fixed bin (37);

	if cyl > legal_cyl then do;			/* cylinder number too big */
	     call ioa_ ("Cylinder ^d too large, cylinder range for this device is 0 to ^d", cyl, legal_cyl);
	     go to error;
	     end;
	if head > legal_hd then do;			/* head number to big */
	     call ioa_ ("Head ^d too large, head range for this device is 0 to ^d", head, legal_hd);
	     go to error;
	     end;
	int_sa = cyl * sect_per_cyl;			/* compute raw cylinder number */
	if int_sa > bounds.high then
	     code = 1;				/* cyl # > # cylinders per device */
	int_sb = head * sect_per_track;		/* compute raw head address */
	if int_sb > sect_per_cyl then
	     code = 2;		     		/* head # > heads per device */
	int_sa = int_sa + int_sb;			/* compute full address */
	if int_sa > bounds.high then
	     code = 3;				/* total address > device capicity */
	if code = 0
	     then return (int_sa);
	     else go to error;


	end form_address;


sort:	proc (key, alt_key);
						/* procedure to sort a new defective address into the bad_trk */
						/* list in ascending order */
dcl  key fixed bin (35);				/* IN  = seek address */
dcl  alt_key fixed bin(35);				/* alt addr if defa */
dcl (i, j) fixed bin;

/* first lets see if we can save ourselves some time and put the bad trk at the end of the list */

	     if bad_trk_count = 0 | key > bad_trks.track_addr (bad_trk_count) then do;
		bad_trk_count = bad_trk_count + 1;
		i, j = bad_trk_count;		/* set constants */
		go to set_new_add;			/* go store the new defective address */
	     end;

	     j = 0;				/* we must sort the new def. address in */
	     do i = 1 to bad_trk_count while (j = 0);
		if i > max_bad_trks then do;
		     call com_err_ ( 0, proc_name, "There are currently ^d bad track entries.^/^a",
			max_bad_trks, "Cannot add more to list." );
		     j = 1;				/* get out of loop */
		     end;
		else if key = FORMAT_INFO.bad_trks(i).track_addr then do; 	/* already exists in list */
		     if rhead ( key ) = legal_hd	/* if last trk on cyl maybe only part of trk used */
			then FORMAT_INFO.bad_trks(i).bad_rcd_cnt = divide ( sect_per_track, sect_per_rec, 17, 0 );
			else FORMAT_INFO.bad_trks(i).bad_rcd_cnt = ceil ( sect_per_track / sect_per_rec );
		     j = 1;			/* let's get out of the loop */
		     end;
		else if key < bad_trks.track_addr (i) then do; /* we found the right slot */
		     bad_trk_count = bad_trk_count + 1; /* increment the counter */
		     do j = bad_trk_count to i + 1 by -1; /* move all the rest of the def trks down one slot */
			FORMAT_INFO.bad_trks(j).track_addr = FORMAT_INFO.bad_trks(j-1).track_addr;
			FORMAT_INFO.bad_trks(j).alt_addr = FORMAT_INFO.bad_trks(j-1).alt_addr;
			FORMAT_INFO.bad_trks(j).bad_rcd_cnt = FORMAT_INFO.bad_trks(j-1).bad_rcd_cnt;
			end;
set_new_add:
		     bad_trks(i).track_addr = key;
		     bad_trks(i).alt_addr = alt_key;
		     if rhead (key) = legal_hd	/* if last trk on cyl maybe only part of trk used */
			then FORMAT_INFO.bad_trks(i).bad_rcd_cnt = divide (sect_per_track, sect_per_rec, 17, 0);
			else FORMAT_INFO.bad_trks(i).bad_rcd_cnt = ceil (sect_per_track / sect_per_rec);
		     end;
		end;
	     return;

	end sort;

remove:	proc (key);
						/* procedure to remove a track from the bad_trk list */
dcl  key fixed bin (35);				/* IN  = seek address */
dcl (i, j) fixed bin;

	     if bad_trk_count = 0
		then return;			/* can't remove someting that isn't there */
	     j = 0;
	     do i = 1 to bad_trk_count while (j = 0);
		if key = bad_trks.track_addr(i) then do;	/* found the trk now remove it from the list */
		     do j = i to bad_trk_count;	/* and take out the blank space */
			bad_trks(j).track_addr = bad_trks(j+1).track_addr;
			bad_trks(j).alt_addr = bad_trks(j+1).alt_addr;
			bad_trks(j).bad_rcd_cnt = bad_trks(j+1).bad_rcd_cnt;
			end;
		     bad_trk_count = bad_trk_count - 1; /* reduce the counter */
		     end;
		end;

	end remove;


read_pack_label: proc;				/* procedure for reading the Multics label record */

dcl  ALPHANUM char (71) init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123457189.?+_-()! ");

	call read_multics_label;
	if code ^= 0 then do;			/* must produce our own error messages */
	     if Option = "read_label"
		then call com_err_ (code, proc_name,
		     "^/While executing a read command on ""Multics label record"".");
	     return;
	     end;

	call ioa_ ("^/Multics label record information:");

	if labelp -> label.Multics ^= Multics_ID_String then do;
	     if ( verify ( labelp->label.pv_name, ALPHANUM ) ) = 0
		then if labelp->label.pv_name ^= " "
		     then call ioa_ ( "^2xphysical volume:^-^a", labelp->label.pv_name );
		     else call ioa_ ( "^2xphysical volume:^-^a", "(blank)" );
		else call ioa_ ( "cannot decipher physical volume name." );
	     if ( verify ( labelp->label.lv_name, ALPHANUM ) ) = 0
		then if labelp->label.lv_name = " "
		     then call ioa_ ( "^2xlogical volume:^-^a", "(blank)" );
		     else call ioa_ ( "^2xlogical volume:^-^a", labelp->label.lv_name );
		else call ioa_ ( "cannot decipher logical volume name." );
	     call ioa_ ("volume is not a ""Multics Storage System Volume""" );
	     multics_storage_system_volume = "0"b;	/*  set this switch (by default it's OFF) */
	     end;

	else do;
	     multics_storage_system_volume = "1"b;	/* make sure it's ON */
	     call ioa_ ( "^2xphysical volume:^-^a", labelp -> label.pv_name );
	     call ioa_ ( "^2xlogical volume:^-^a", labelp -> label.lv_name );
	     call date_time_ ( labelp -> label.time_registered, ltime );
	     call ioa_ ( "^2xregistered on:^-^a", ltime );
	     if labelp->label.nparts > 0 then do;	/* Aha, partitions present.  */
		call ioa_ ( "^2x# partitions:^-^d", labelp -> label.nparts );
		if labelp->label.nparts > 47		/* legal # of partitions MUST be < 48 */
		     then call ioa_ ("^5x(Number partitions too great!)");
		     else do j = 1 to labelp->label.nparts;
			call ioa_ ( "      ^4a^-from ^d for ^d", labelp -> label.parts(j).part,
			     labelp -> label.parts(j).frec, labelp -> label. parts(j).nrec );
			if labelp->label.parts(j).part = "alt"	/* look for "alt" partition */
			     then alt_partition_present = "1"b;
		     end;
		end;
	     else do;
		alt_partition_present = "0"b;
						/* shouldn't allow user to format_tracks on a valid */
						/* Multics pack which has NO alt partition */
		call ioa_ ("no partitions specified in label." );
		end;
	     end;

	call ioa_ ("legal cylinders:^-0:^d", legal_cyl);
	call ioa_ ("legal heads:^-0:^d^/", legal_hd );

	end read_pack_label;

						/* procedure to actually read the Multics label record */
read_multics_label: proc;

	labelp = addr (MULTICS_LABEL);
	seek_key = mul_phy (multics_lab_rec);
	call iox_$seek_key (iocb_ptr, asc (seek_key), rec_len, code);
	call iox_$read_record (iocb_ptr, labelp, 1024 * 4, rec_len, code);
	return;

	end read_multics_label;
     end format_disk_pack;




		    io_error_summary.pl1            10/21/92  1555.7rew 10/21/92  1551.0      490077



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


/****^  HISTORY COMMENTS:
  1) change(85-09-11,Farley), approve(85-09-11,MCR6979),
     audit(86-02-18,Coppola), install(92-10-21,MR12.5-1037):
     Add support for FIPS disk and tape.
  2) change(85-12-18,Farley), approve(85-12-18,MCR7318),
     audit(86-02-18,Coppola), install(92-10-21,MR12.5-1037):
     bug fixes, plus one new arg.
  3) change(92-10-02,WAAnderson), approve(92-10-02,MCR8276),
     audit(92-10-14,Vu), install(92-10-21,MR12.5-1037):
     1) Added support for fdisk_status_table_.alm 2) Added support for device
     channels. (ie -channel control arg & new column) 3) Added sector number
     for -cylinder argument. 4) Corrected problem with data bit error counts.
                                                   END HISTORY COMMENTS */
/* IO_ERROR_SUMMARY: Command to summarize I/O errors from the syserr log */

/* Coded January-February 1976 by Larry Johnson */
/* Modified May 1976 by Larry Johnson for new config cards and disk and opc devices */
/* Modified March 1977 by Larry Johnson to get device names from log instead of config deck */
/* Modified November 1979 by Larry Johnson for detailed device status */
/* Modified January 1980 by Larry Johnson to use hashing to improve performance */
/* Modified October 1980 by Rich Coppola to reduce superflous output from detail status */
/* Modified May 1981 by Rich Coppola to add interface to analyze_detail_stat_
   add -status (-st) arg and the -hex_detail_status (-hxdtst) arg. */
/* Modified Apr 1982 by Rich Coppola to add support of PR54 printer and MPT Tape drives */
/* Modified September 1982 by C. Hornig for PRPH TAP card change. */
/* Modified Oct 1982 by Rich Coppola to use new calling sequence to
   analyze_detail_stat_$rs/rsnnl and remove some superflous code for detail
   status analysis that was better done in analyze_detail_stat_.
*/
/* Modified Jan. 28, 1983 by Paul Farley to add a "-io_command(-ioc)" arg to */
/* allow for displaying the IO command executed prior to recieving the error. */
/* Modified Nov 1983 by Paul Farley to fix TR 16222,16432
   Modified Jan 1984 by Paul Farley to fix TR 14550
   Modified Jan 1985 by Paul Farley to pack ascii formatted detailed status
   from EURCs and UR-IPCs before printing in HEX or before analyzing.
   Modified Feb 1985 by Paul Farley to check for null ptrs from config_.
   Modified July 1985 by Paul Farley for FIPS disk/tape.
*/

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

io_error_summary:
     proc;

dcl  code fixed bin (35);				/* Standard system status code */
dcl  open_status bit (36) aligned;			/* Code from syserr_log_util_$open */
dcl  tab_cnt fixed bin init (0);			/* Number of seperate status found */
dcl  indent fixed bin;				/* The number of spaces to indent */
dcl  (i, j) fixed bin;
dcl  mode fixed bin (5);
dcl  stat_tablep ptr internal static;			/* Pointer to device status table */
dcl  my_tape_analp ptr;				/* Pointer to tape detail status analysis */
dcl  my_disk_analp ptr;
dcl  my_prt_analp ptr;
dcl  mask bit (36) aligned;				/* Mask of significant bits in status word */
dcl  arg_ptr ptr;					/* Pointer to an argument */
dcl  arg_len fixed bin;				/* Length of an argument */
dcl  arg char (arg_len) based (arg_ptr);		/* A command argument */
dcl  arg_count fixed bin;				/* The number of arguments */
dcl  arg_list_ptr ptr;				/* Pointer to commands argument list */
dcl  for_ptr ptr;					/* Saved pointer to the -for argument */
dcl  for_len fixed bin;				/* Saved length of -for argument */
dcl  for_arg char (for_len) based (for_ptr);		/* This is the -for argument */
dcl  from_sw bit (1) init ("0"b);			/* Set if -from used */
dcl  to_sw bit (1) init ("0"b);			/* Set if -to used */
dcl  for_sw bit (1) init ("0"b);			/* Set if -for used */
dcl  detailed_status_sw bit (1) init ("0"b);		/* Set if -dtstat specified */
dcl  hex_detailed_status_sw bit (1) init ("0"b);		/* Set if user want to see hex detail status */
dcl  chn_sw bit (1) init ("0"b);			/* Set if user wants to see channel */
dcl  cyl_sw bit (1) init ("0"b);			/* Set if user wants to see disk addresses */
dcl  tdbie_sw bit (1) init ("0"b);			/* Set if user wants to see tape data bits in error */
dcl  io_cmd_sw bit (1) init ("0"b);			/* Set if user wants to see the I/O commands */
dcl  fips_controller bit (1) init ("0"b);
dcl  more_args bit (1);				/* Set while there are more arguments to scan */
dcl  from_time fixed bin (71);			/* Time specified on -from */
dcl  to_time fixed bin (71);				/* Time specified on -to */
dcl  for_time fixed bin (71);				/* Time specified on -for */
dcl  arg_no fixed bin init (1);			/* For scanning argument list */
dcl  statentp ptr;					/* Pointer to status table entry */
dcl  msg_time fixed bin (71);				/* Time of syserr message */
dcl  msg_seq fixed bin (35);				/* Sequence number */
dcl  dev_cnt fixed bin init (0);			/* Number of devices requested */
dcl  stat_req_cnt fixed bin init (0);			/* Number of stati requested */
dcl  stat_cnt fixed bin init (0);			/* Entries in status table */
dcl  devreq (32) char (7) var;			/* Table of requested devices */
dcl  1 statreq (32),				/* Table of requested stati */
       2 statreq_maj bit (4),				/* major status */
       2 statreq_min bit (6);				/* minor status */
dcl  1 dev_pack_list (20) aligned,
       2 valid bit (1) aligned,
       2 device char (4) aligned,
       2 pack bit (1) aligned;
dcl  1 dev_idx_list (20) aligned,
       2 valid bit (1) aligned,
       2 device_name char (8) aligned,
       2 device_idx fixed bin aligned;
dcl  1 disk_list (20) aligned,
       2 valid bit (1) aligned,
       2 device_name char (8) aligned,
       2 fips bit (1) aligned;
dcl  stat_arg fixed bin (35);
dcl  buffer (500) bit (36) aligned;			/* Syserr messages are read here */
dcl  sortp ptr;					/* Segment containing sort array */
dcl  areap ptr;					/* Work area */
dcl  hashp ptr;
dcl  chars_in_sort_info fixed bin;
dcl  1 auto_area_info aligned like area_info automatic;

dcl  meter_sw bit (1) init ("0"b);			/* Set if -meter used */
dcl  total_time fixed bin (71);
dcl  open_time fixed bin (71);
dcl  scan_time fixed bin (71);
dcl  count_time fixed bin (71);
dcl  sort_time fixed bin (71);
dcl  start_count fixed bin (71);
dcl  print_time fixed bin (71);
dcl  n_counted fixed bin (35);
dcl  n_statuses fixed bin (35);
dcl  longest_chain fixed bin;
dcl  buckets_used fixed bin;
dcl  mpc_model fixed bin init (0);
dcl  oct_char (0:7) char (1) int static options (constant) init ("0", "1", "2", "3", "4", "5", "6", "7");
dcl  analysis_char_count fixed bin;
dcl  analysis_string char (256) var init ("");
dcl  display_detail_count fixed bin;
dcl  null_tape_tracks char (18) init ((18)"-");
dcl  dbie_counts (9) fixed bin;
dcl  track_analysis char (256) var;

/* Constants */

dcl  name char (16) int static options (constant) init ("io_error_summary");
						/* Name of procedure */
dcl  n_buckets fixed bin int static options (constant) init (2047);


dcl  mth500_mask bit (208) int static options (constant) init ("f3ffffffffffffffffffff000000002011002000000040000000"b4);

dcl  mth600_mask bit (208) int static options (constant) init ("f3ffffffff00ffffff01000000000000ffffffffffffffffffff"b4);

dcl  mth610_mask bit (208) int static options (constant) init ("f3ffffffff00ffff000000000a000400ffffffffffffffffffff"b4);

dcl  mth640_mask bit (208) int static options (constant) init ("f3ffffffffe0ffe7ff17000000000000ffffffffffffffffffff"b4);

dcl  mtc500_mask bit (208) int static options (constant) init ("ffffffffffffffffffffffffffffffff00000000000000000000"b4);

dcl  mtp601_mask bit (208) int static options (constant) init ("fffffffffffffffffffffffffffffffffffffffffef200000000"b4);

dcl  mtp610_mask bit (208) int static options (constant) init ("ffffffffffffffffffffffffffffffffffffffff7a820727003f"b4);

dcl  fips_tape_mask bit (208) int static options (constant)
	init ("fe85fffdf23640fd80f8950000000000000000000000ff000000"b4);

dcl  pr71_mask bit (128) int static options (constant) init ("ffffffffffffffffffffff0000000000"b4);

dcl  pr54_mask bit (128) int static options (constant) init ("800000c00000000000000000ff000080"b4);

dcl  db_trk_str9 char (58) int static options (constant)
	init ("Data Bit/Track 0/7  1/6  2/5  3/3  4/9  5/1  6/8  7/2  P/4");

dcl  db_trk_str7 char (49) int static options (constant) init ("Data Bit/Track  2/6  3/5  4/4  5/3  6/2  7/1  P/7");

dcl  DEV_LEN fixed bin int static options (constant) init (9);
dcl  CHN_LEN fixed bin int static options (constant) init (4);
dcl  IOC_LEN fixed bin int static options (constant) init (5);

/* Based */

dcl  1 sort_list aligned based (sortp),
       2 count fixed bin (35),
       2 entryp (0 refer (sort_list.count)) ptr unal;

dcl  hash_table (n_buckets) ptr unal based (hashp);

dcl  1 stat aligned based (statentp),			/* Entry for each different status found */
       2 sort_info like stat_sort_info,
       2 next ptr unal,				/* Next in chain */
       2 count fixed bin (17) unal;			/* Number of occurances of the status */

dcl  1 stat_sort_info aligned based,
       2 devname char (8),				/* Name of device */
       2 chnname char (8),
       2 time_out_sort char (1) unal,			/* Make time outs sort before rest */
       2 sysfault_sort char (1) unal,			/* Make system faults sort before rest */
       2 pad char (2) unal,
       2 dsk_sect fixed bin (24),			/* seek field fom dsk_ctl */
       2 pad1 fixed bin (12) unal,
       2 dsk_mult_rec char (8),			/* and the assoc record */
       2 status bit (36),				/* The status */
       2 command char (2) unal,			/* IO command */
       2 pad2 char (2) unal,
       2 detailed_status bit (216);			/* The detailed status */

dcl  work_area area based (areap);

/* External */

dcl  syserr_log_util_$open entry (bit (36) aligned, fixed bin (35));
dcl  print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35));
dcl  syserr_log_util_$close entry (fixed bin (35));
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$rsnnl entry () options (variable);
dcl  ioa_$rs entry () options (variable);
dcl  ioa_$rsnpnnl entry options (variable);
dcl  syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35));
dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
dcl  analyze_detail_stat_$rsnnl entry (char (*), bit (36) aligned, bit (*) unal, char (*) var, bit (1), fixed bin (35));
dcl  analyze_detail_stat_ entry (char (*), bit (36) aligned, bit (*) unal, ptr, fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  cu_$arg_list_ptr entry (ptr);
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr);
dcl  convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
dcl  convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35));
dcl  config_$find entry (char (4) aligned, ptr);
dcl  config_$find_periph entry (char (4) aligned, ptr);
dcl  config_$find_peripheral entry (char (4) aligned, fixed bin (3), fixed bin (8), bit (36) aligned, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35));
dcl  define_area_ entry (ptr, fixed bin (35));
dcl  release_area_ entry (ptr);
dcl  sort_items_$bit entry (ptr, fixed bin (24));
dcl  hash_index_ entry (ptr, fixed bin, fixed bin, fixed bin) returns (fixed bin);
dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl  parse_io_channel_name_ entry (char (*), fixed bin (3), fixed bin (6), fixed bin (35));

dcl  error_table_$no_r_permission fixed bin (35) ext static;
dcl  error_table_$end_of_info ext fixed bin (35);
dcl  error_table_$badopt ext fixed bin (35);
dcl  sys_info$max_seg_size fixed bin (35) ext static;
dcl  disk_status_table_$disk_status_table_ ext;
dcl  fdisk_status_table_$fdisk_status_table_ ext;
dcl  opc_status_table_$opc_status_table_ ext;
dcl  tape_status_table_$tape_status_table_ ext;
dcl  prt_status_table_$prt_status_table_ ext;
dcl  cpz_status_table_$cpz_status_table_ ext;
dcl  crz_status_table_$crz_status_table_ ext;
dcl  config_deck$ ext;
dcl  cleanup condition;

dcl  (addr, bin, divide, fixed, float, hbound, index, lbound, length, ltrim, max, mod, null, rtrim, size, substr,
     subtract, unspec, vclock, bit) builtin;
%page;
/* Initialization */

	total_time = vclock ();
	areap = null ();
	sortp = null ();
	unspec (dev_pack_list (*)) = ""b;
	unspec (dev_idx_list (*)) = ""b;
	on cleanup call clean_up;

	call get_temp_segment_ (name, sortp, code);	/* Get a work segment */
	if code ^= 0 then do;
	     call com_err_ (code, name, "Can't get temp segment");
	     go to done;
	     end;
	sort_list.count = 0;

	area_infop = addr (auto_area_info);
	unspec (area_info) = "0"b;
	area_info.version = area_info_version_1;
	area_info.owner = name;
	area_info.size = sys_info$max_seg_size;
	area_info.areap = null ();
	area_info.control.extend = "1"b;
	area_info.no_freeing = "1"b;
	call define_area_ (area_infop, code);
	if code ^= 0 then do;
	     call com_err_ (code, name, "Unable to setup area.");
	     go to done;
	     end;

	areap = area_info.areap;
	allocate stat_sort_info in (work_area) set (hashp);
						/* Dummy, to get size */
	chars_in_sort_info = 4 * size (hashp -> stat_sort_info);

	allocate hash_table in (work_area);
	hash_table (*) = null ();

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

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

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

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

	indent = 0;

	if chn_sw
	then indent = DEV_LEN + CHN_LEN;
	else indent = DEV_LEN;

	if io_cmd_sw then indent = indent + IOC_LEN;

	syserr_msgp = addr (buffer);			/* Read here */
	mask = "0"b;
	statp = addr (mask);			/* Initialize mask of important things in status word */
	status.t = "1"b;
	status.power = "1"b;
	status.major = "1111"b;
	status.sub = "111111"b;
	status.channel_stat = "111"b;
	status.central_stat = "111"b;

	if detailed_status_sw then do;		/* check callers access to the config_deck, without it can do nothing for him */


	     call hcs_$fs_get_mode (addr (config_deck$), mode, code);
	     if code ^= 0 then do;
no_cd_access:
		call com_err_ (code, name, "Cannot decode detailed status.");
		return;
		end;
	     if (bit (mode) & bit (R_ACCESS_BIN)) ^= bit (R_ACCESS_BIN) then do;
		code = error_table_$no_r_permission;
		goto no_cd_access;
		end;
	     end;


%page;
/* Loop thru the file */

	scan_time = vclock ();
	count_time = 0;
	n_counted, n_statuses = 0;

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

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

	if syserr_msg.data_code = SB_io_err | syserr_msg.data_code = SB_io_err_detail
	     | syserr_msg.data_code = SB_disk_err | syserr_msg.data_code = SB_ocdcm_err then do;
	     start_count = vclock ();
	     n_counted = n_counted + 1;
	     call count_it;
	     count_time = count_time + (vclock () - start_count);
	     end;
	go to loop;

/* End of log reached */

print:
	scan_time = vclock () - scan_time - count_time;

	sort_time = vclock ();
	if sort_list.count > 0 then call sort_items_$bit (sortp, 9 * chars_in_sort_info);
	sort_time = vclock () - sort_time;

	print_time = vclock ();
	call print_it;				/* Print results */
	print_time = vclock () - print_time;

/* End of command */

	total_time = vclock () - total_time;

	if meter_sw then do;
	     call ioa_ ("^2/");
	     call ioa_ ("Total:^-^.1f", float (total_time) / 1.0e6);
	     call ioa_ ("Open:^-^.1f", float (open_time) / 1.0e6);
	     call ioa_ ("Scan:^-^.1f", float (scan_time) / 1.0e6);
	     call ioa_ ("Count:^-^.1f (^d records, ^d statuses)", float (count_time) / 1.0e6, n_counted, n_statuses);
	     call ioa_ ("Sort:^-^.1f (^d entries)", float (sort_time) / 1.0e6, sort_list.count);
	     call ioa_ ("Print:^-^.1f", float (print_time) / 1.0e6);
	     buckets_used = 0;
	     longest_chain = 0;
	     do i = 1 to hbound (hash_table, 1);
		if hash_table (i) ^= null () then do;
		     buckets_used = buckets_used + 1;
		     j = 0;
		     do statentp = hash_table (i) repeat (stat.next) while (statentp ^= null ());
			j = j + 1;
		     end;
		     longest_chain = max (j, longest_chain);
		     end;
	     end;
	     call ioa_ ("^d of ^d buckets used, longest list was ^d", buckets_used, n_buckets, longest_chain);
	     end;

done:
	call clean_up;
	return;
%page;
/* Procedure to scan the argument list */

scan_args:
     proc;

	do while (more_args);			/* Do while thins to look at */
	     call get_arg;
	     if arg = "-from" | arg = "-fm" then do;	/* Start time */
		from_sw = "1"b;
		call time_arg (from_time);
		end;
	     else if arg = "-to" then do;		/* Ending time */
		to_sw = "1"b;
		call time_arg (to_time);
		end;
	     else if arg = "-for" then do;		/* Time limit */
		for_sw = "1"b;
		call time_arg (for_time);		/* For syntax checking only */
		for_len = arg_len;			/* Save pointer to this argument */
		for_ptr = arg_ptr;
		end;
	     else if arg = "-device" | arg = "-dv" then do;
						/* List of devices */
		if ^more_args then do;		/* Need more args */
no_dev:
		     call com_err_ (0, name, "Argument missing after -device");
		     go to done;
		     end;
		call get_arg;
		if substr (arg, 1, 1) = "-" then go to no_dev;
						/* Shouldn't be control arg */
new_dev:
		dev_cnt = dev_cnt + 1;		/* Count device found */
		devreq (dev_cnt) = arg;		/* Save name */
		if more_args then do;		/* If more to scan */
		     call get_arg;
		     if substr (arg, 1, 1) ^= "-" then do;
						/* Found another device */
			if dev_cnt < hbound (devreq, 1)
			then go to new_dev;
			else do;			/* Too many */
			     call com_err_ (0, name, "There were more than ^d devices specified.",
				hbound (devreq, 1));
			     go to done;
			     end;
			end;
		     else call put_arg;		/* Went too far, back up 1 */
		     end;
		end;

	     else if arg = "-status" | arg = "-st" then do;
						/* List of statuses */
		if ^more_args then do;		/* Need more args */
no_stat:
		     call com_err_ (0, name, "Argument missing after -status");
		     go to done;
		     end;
		call get_arg;
		if substr (arg, 1, 1) = "-" then go to no_stat;
						/* Shouldn't be control arg */
new_stat:
		stat_req_cnt = stat_req_cnt + 1;	/* Count status found */
		stat_arg = cv_oct_check_ (arg, code);
		if code ^= 0 then do;

		     call com_err_ (code, name, "Status must be octal.");
		     go to done;
		     end;
		statreq.statreq_maj (stat_req_cnt) = substr (unspec (stat_arg), 27, 4);
		statreq.statreq_min (stat_req_cnt) = substr (unspec (stat_arg), 31, 6);
		if more_args then do;		/* If more to scan */
		     call get_arg;
		     if substr (arg, 1, 1) ^= "-" then do;
						/* Found another status */
			if stat_req_cnt < hbound (statreq, 1)
			then go to new_stat;
			else do;			/* Too many */
			     call com_err_ (0, name, "There were more than ^d statuses specified.",
				hbound (statreq, 1));
			     go to done;
			     end;
			end;
		     else call put_arg;		/* Went too far, back up 1 */
		     end;
		end;


	     else if arg = "-detailed_status" | arg = "-dtstat" | arg = "-dtst" then detailed_status_sw = "1"b;

	     else if arg = "-hex_detailed_status" | arg = "-hxdtstat" | arg = "-hxdtst"
	     then hex_detailed_status_sw = "1"b;
	     else if arg = "-meter" then meter_sw = "1"b;

	     else if arg = "-cylinders" | arg = "-cyl" then cyl_sw = "1"b;

	     else if arg = "-tape_data_bit_in_error" | arg = "-tdbie" then tdbie_sw = "1"b;

	     else if arg = "-io_command" | arg = "-ioc" then io_cmd_sw = "1"b;
	     else if arg = "-channel" | arg = "-chn" then chn_sw = "1"b;

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


	if to_sw & for_sw then do;			/* Conflict */
	     call com_err_ (0, name, "Conflicting arguments: -to and -for");
	     go to done;
	     end;

	if hex_detailed_status_sw & detailed_status_sw then do;
						/* ditto */
	     call com_err_ (0, name, "Conflicting arguments: -hex_detailed_status and -detailed_status.");
	     go to done;
	     end;


	return;

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

get_arg:
     proc;

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

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

     end get_arg;

/* Procedure to convert a time argument */

time_arg:
     proc (t);

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

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

	return;

     end time_arg;
%page;
/* Procedure to count a status */

count_it:
     proc;

dcl  ntimes fixed bin;				/* Number of times status occured */
dcl  dev_edit picture "99";
dcl  dev_name char (3);
dcl  detail_temp char (71);				/* 24 bytes */
dcl  (start_char, start_pos) fixed bin;
dcl  1 temp_stat like stat aligned automatic;
dcl  bucket_no fixed bin;
dcl  i fixed bin;
dcl  p ptr;
dcl  temp_char char (8);


	if syserr_msg.data_size < 5
	then					/* not enough info to do aanything */
	     return;

	unspec (temp_stat) = "0"b;
	statentp = addr (temp_stat);
	stat.dsk_sect = 0;
	stat.dsk_mult_rec = "";
	stat.next = null ();

	io_msgp = addr (syserr_msg.data);		/* Point at data portion */

	ntimes = bin (io_msg.count) + 1;
	n_statuses = n_statuses + ntimes;
	stat.devname = io_msg.devname;		/* Pick up name of device */
	if chn_sw
	then stat.chnname = io_msg.channel;		/* Pick up name of channel */
	else stat.chnname = "";

	if substr (stat.devname, 1, 3) = "dsk" | substr (stat.devname, 1, 3) = "tap" then do;
	     substr (stat.devname, 5, 1) = "_";
	     dev_edit = bin (io_msg.device);
	     substr (stat.devname, 6, 2) = dev_edit;
	     end;

	if dev_cnt > 0 then do;			/* Only doing certain devices */
	     do i = 1 to dev_cnt;
		if substr (stat.devname, 1, length (devreq (i))) = devreq (i) then go to dev_wanted;
	     end;
	     return;				/* Not wanted */
dev_wanted:
	     end;

	if stat_req_cnt > 0 then do;			/* Only doing certain stati */
	     do i = 1 to stat_req_cnt;
		if substr (io_msg.status, 3, 4) = statreq.statreq_maj (i) then do;
						/* special case 00 status */
		     if statreq.statreq_min (i) = "00"b3 then do;
			if substr (io_msg.status, 7, 6) = statreq.statreq_min (i) then go to stat_wanted;
			end;

		     else if substr (io_msg.status, 7, 6) & statreq.statreq_min (i) then go to stat_wanted;
		     end;
	     end;
	     return;				/* Not wanted */
stat_wanted:
	     end;


	stat.time_out_sort = "1";			/* 1 means not timeout */
	stat.sysfault_sort = "1";
	if io_cmd_sw
	then stat.command =
		oct_char (bin (substr (io_msg.command, 1, 3))) || oct_char (bin (substr (io_msg.command, 4, 3)));
	else stat.command = "";

	if io_msg.level = "001"b then do;		/* System fault */
	     stat.status = io_msg.status;		/* Use all status */
	     stat.sysfault_sort = "0";		/* To sort before other status */
	     end;

	else if io_msg.level = "011"b then do;		/* If terminate */
	     if io_msg.time_out then do;
		stat.time_out_sort = "0";		/* To sort before others */
		stat.status = "0"b;			/* No status if time out */
		end;

	     else stat.status = io_msg.status & mask;	/* Keep just good part of rest */
	     if cyl_sw = "1"b
	     then					/* only if he wants 'em */
		if index (syserr_msg.text, "disk_control:") ^= 0 then do;
		     stat.dsk_mult_rec = "";
		     start_char = index (syserr_msg.text, "rec ");
		     if start_char > 0
		     then stat.dsk_mult_rec =
			     substr (syserr_msg.text, start_char + 4,
			     (index (substr (syserr_msg.text, start_char + 4), ",") - 1));

		     start_char = index (syserr_msg.text, ", sect ");
		     if start_char > 0
		     then temp_char =
			     substr (syserr_msg.text, start_char + 7,
			     (index (substr (syserr_msg.text, start_char + 7), ",") - 1));

		     stat.dsk_sect = cv_oct_check_ (temp_char, code);
		     end;

	     if (detailed_status_sw | hex_detailed_status_sw) then do;
		if syserr_msg.data_size = 11 then do;
		     dev_name = substr (stat.devname, 1, 3);

		     if dev_name = "prt" | dev_name = "rdr" | dev_name = "pun" then call pack_detail;

		     if dev_name = "dsk" then do;
			if fips_disk (stat.devname)
			then stat.detailed_status = substr (io_msg.detailed_status, 1, 192);
						/* fips disks have 24 bytes */
			else stat.detailed_status = substr (io_msg.detailed_status, 1, 112);
						/* others have 14 bytes */
			end;

		     else if dev_name = "tap" then do;
			stat.detailed_status = substr (io_msg.detailed_status, 1, 208);
						/* Only want 26 bytes */
			if stat.detailed_status = "0"b then go to sort_it;
			if detailed_status_sw then call process_tape_status;

			end;


		     else if dev_name = "prt" then do;
			stat.detailed_status = substr (io_msg.detailed_status, 1, 128);
						/* Only want 16 bytes */

			if stat.detailed_status = "0"b then go to sort_it;
			if detailed_status_sw then call process_prt_status ((stat.devname));
			end;

		     else if dev_name = "rdr" | dev_name = "pun"
		     then stat.detailed_status = substr (io_msg.detailed_status, 1, 72);
						/* Only want 9 bytes */

		     else stat.detailed_status = io_msg.detailed_status;
						/* If none of the above give it all */
		     end;

		else if index (syserr_msg.text, "disk_control:") ^= 0
		     & index (syserr_msg.text, "detailed status:") ^= 0 then do;
		     start_pos = index (syserr_msg.text, "detailed status:") + 17;
		     if start_pos > 0 then do;
			detail_temp =
			     substr (syserr_msg.text, start_pos, (syserr_msg.text_len - 1) - (start_pos - 1));
			if fips_disk (stat.devname)
			then stat.detailed_status = cv_detail (detail_temp, 24);
			else stat.detailed_status = cv_detail (detail_temp, 14);
			end;

		     end;
		end;

	     end;

	else return;
%page;
sort_it:
	bucket_no = hash_index_ (addr (stat.sort_info), chars_in_sort_info, 13, n_buckets) + 1;

	do p = hash_table (bucket_no) repeat (p -> stat.next) while (p ^= null ());
	     if unspec (p -> stat.sort_info) = unspec (stat.sort_info) then do;
		p -> stat.count = p -> stat.count + ntimes;
		return;
		end;
	end;

	allocate stat in (work_area) set (p);
	p -> stat = stat;
	p -> stat.count = ntimes;
	p -> stat.next = hash_table (bucket_no);
	hash_table (bucket_no) = p;

	sort_list.count = sort_list.count + 1;
	sort_list.entryp (sort_list.count) = p;
	return;
%page;
cv_detail:
	proc (detail_string, bytes_wanted) returns (bit (216));
dcl  detail_string char (*);
dcl  bytes_wanted fixed bin;
dcl  (det_idx, bit_idx, hex_idx) fixed bin;
dcl  detailed_bits bit (216) init (""b);

	     det_idx = 1;
	     do bit_idx = 1 to bytes_wanted * 8 by 4;	/* index thru bit string */
find_hex_idx:
		hex_idx = index ("0123456789ABCDEF", substr (detail_string, det_idx, 1));
		if hex_idx = 0 then do;		/* skip spaces or other bad things */
		     det_idx = det_idx + 1;
		     goto find_hex_idx;
		     end;
		substr (detailed_bits, bit_idx, 4) = bit (subtract (hex_idx, 1, 4), 4);
		det_idx = det_idx + 1;
	     end;
	     return (detailed_bits);
	end cv_detail;
%page;
pack_detail:
	proc;
dcl  temp_detail bit (216);
dcl  1 unpacked (24) based (unpack_ptr),
       2 unused bit (1) unaligned,
       2 data bit (8) unaligned;
dcl  packed (27) bit (8) unaligned based (pack_ptr);
dcl  (pack_ptr, unpack_ptr) ptr;
dcl  periph char (4) aligned;
dcl  (dev_idx, byte_idx) fixed bin;
dcl  do_pack bit (1);
dcl  iom_no fixed bin (3);
dcl  chan_no fixed bin (8);
	     periph = substr (stat.devname, 1, 4);
	     do dev_idx = 1 to hbound (dev_pack_list, 1) while (dev_pack_list (dev_idx).valid);
		if dev_pack_list (dev_idx).device = periph then goto pack_it;
	     end;
	     call config_$find_peripheral (periph, iom_no, chan_no, ""b, code);
	     if code ^= 0 then do;
		do_pack = "0"b;
		goto save_info;
		end;
	     mpc_cardp = null ();
	     do while ("1"b);
		call config_$find ("mpc", mpc_cardp);
		if mpc_cardp = null () then do;
		     do_pack = "1"b;
		     goto save_info;
		     end;
		do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.port (i).iom ^= -1);
		     if (iom_no = mpc_card.port (i).iom) & (chan_no >= mpc_card.port (i).chan)
			& (chan_no < mpc_card.port (i).chan + mpc_card.port (i).nchan) then do;
			if mpc_card.model = 2 | mpc_card.model = 600
			then do_pack = "0"b;
			else do_pack = "1"b;
			goto save_info;
			end;
		end;
	     end;
save_info:
	     if dev_idx > hbound (dev_pack_list, 1) then dev_idx = hbound (dev_pack_list, 1);
	     dev_pack_list (dev_idx).valid = "1"b;
	     dev_pack_list (dev_idx).device = periph;
	     dev_pack_list (dev_idx).pack = do_pack;
pack_it:
	     if ^dev_pack_list (dev_idx).pack then return;
	     unpack_ptr = addr (io_msg.detailed_status);
	     pack_ptr = addr (temp_detail);
	     temp_detail = ""b;			/* clear it out */
	     do byte_idx = 1 to hbound (unpacked, 1);	/* Pack it up */
		packed (byte_idx) = unpacked (byte_idx).data;
	     end;
	     io_msg.detailed_status = temp_detail;	/* copy back */
	     return;
	end pack_detail;
     end count_it;
%page;
/* Procedure to print results */

print_it:
     proc;

dcl  (tm1, tm2) char (24);				/* For editing times */
dcl  msg char (256) var;				/* Build status message here */
dcl  (break, is_interesting) bit (1);			/* Flags */
dcl  prev_dev char (8) init ("");
dcl  (i, j, k) fixed bin;
dcl  p ptr;
dcl  name_ck char (3);
dcl  total_status fixed bin;
dcl  ndtstats fixed bin;
dcl  dtstat (1:27) bit (8) unal based (addr (stat.detailed_status));
dcl  temp_detailed_status bit (208) unal based (addr (stat.detailed_status));
dcl  (cyl, head, isect) fixed bin (24);


	call date_time_ (from_time, tm1);		/* Edit start */
	call date_time_ (to_time, tm2);
	call ioa_ ("^/Summary from ^a to ^a^/^/", tm1, tm2);
	call ioa_ ("DEVICE^3x^[CHN^x^;^]^[CMD^2x^;^]COUNT^xIOM STATUS^[/DETAILED STATUS^]", chn_sw, io_cmd_sw,
	     (detailed_status_sw | hex_detailed_status_sw));

	stat_tablep = null ();
	do i = 1 to sort_list.count;
	     statentp = sort_list.entryp (i);
	     break = (prev_dev ^= stat.devname);
	     prev_dev = stat.devname;
	     total_status = stat.count;
	     if break then call pick_status_table;
	     ndtstats = 0;
	     display_detail_count = 0;
	     analysis_string = "";
	     dbie_counts (*) = 0;

	     if (detailed_status_sw | hex_detailed_status_sw) then do;
		do j = i + 1 to sort_list.count;
		     p = sort_list.entryp (j);
		     if p -> stat.devname ^= stat.devname then go to end_dup_scan;
		     if p -> stat.sysfault_sort ^= stat.sysfault_sort then go to end_dup_scan;
		     if p -> stat.time_out_sort ^= stat.time_out_sort then go to end_dup_scan;
		     if p -> stat.status ^= stat.status then go to end_dup_scan;
		     if p -> stat.command ^= stat.command then go to end_dup_scan;
		     if p -> stat.dsk_mult_rec ^= stat.dsk_mult_rec then go to end_dup_scan;

		     total_status = total_status + p -> stat.count;
		     ndtstats = ndtstats + 1;
		end;
end_dup_scan:
		end;

	     if stat.time_out_sort = "0" then msg = "Channel timed out.";
	     else if stat.sysfault_sort = "0" then call ioa_$rsnpnnl ("System fault: ^w", msg, (0), stat.status);
	     else call analyze_device_stat_$rsnnl (msg, stat_tablep, (stat.status), ("0"b));
	     call ioa_ ("^[^/^8a^x^;^9x^s^]^[^3a^x^;^s^]^[(^2a)^x^;^s^]^5d^x^a", break, stat.devname, chn_sw,
		stat.chnname, io_cmd_sw, stat.command, total_status, msg);

	     if stat.dsk_mult_rec ^= "" then do;
		call convert_seek_addr (stat.dsk_sect, stat.devname, stat.chnname, cyl, head, isect);
		call ioa_ ("^vx^6xCylinder ^[???^s^;^3d^] Head ^[??^s^;^2d^] Sector ^[???^s^;^3d^] Record ^a", indent,
		     (cyl = -1), cyl, (head = -1), head, (isect = -1), isect, stat.dsk_mult_rec);
		end;

	     if hex_detailed_status_sw then do;
		do j = i to i + ndtstats;
		     statentp = sort_list.entryp (j);
		     if stat.detailed_status ^= "0"b then do;
			name_ck = substr (stat.devname, 1, 3);
			if name_ck = "dsk" then do;
			     if fips_disk (stat.devname)
			     then k = 24;		/* 24 bytes for fips */
			     else k = 11;		/* 11 bytes for others */
			     end;
			else if name_ck = "tap" then k = 26;
						/* print 26 bytes */
			else if name_ck = "prt" then k = 16;
						/* print 15 bytes */
			else if name_ck = "rdr" | name_ck = "pun" then k = 9;
						/* print 9 bytes */
			else do k = hbound (dtstat, 1) to lbound (dtstat, 1) + 1 by -1 while (dtstat (k) = "0"b);
			end;
			call ioa_ ("^vx^5d^3x^v( ^.4b^)", indent, stat.count, k, dtstat);
			end;
		end;
		i = i + ndtstats;
		end;

	     else if detailed_status_sw then do;
		do j = i to i + ndtstats;
		     statentp = sort_list.entryp (j);
		     if stat.detailed_status ^= "0"b then do;
			if substr (stat.devname, 1, 3) = "tap" then do;
			     call analyze_detail_stat_ ((stat.devname), stat.status, temp_detailed_status,
				my_tape_analp, code);
			     if code ^= 0 then go to end_anal_display;

			     tape_analp = my_tape_analp;

			     if tape_analysis.num_analyzed = 0
			     then if tdbie_sw = "0"b then go to end_anal_display;

			     if tape_analysis.num_analyzed = 0
			     then if (tdbie_sw = "1"b & tape_analysis.tracks_in_error = null_tape_tracks)
				then go to end_anal_display;

			     call tally_details_tape_;
			     if j = i + ndtstats then do;
				call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, analysis_string);
				if tdbie_sw = "1"b then call ioa_ ("^vx^6x^a", indent, rtrim (track_analysis));
				end;
			     go to end_anal_display;
			     end;			/* end tape display */

			else if substr (stat.devname, 1, 3) = "dsk" then do;

			     call analyze_detail_stat_ ((stat.devname), stat.status, (stat.detailed_status),
				my_disk_analp, code);
			     if code ^= 0 then go to end_anal_display;

			     disk_analp = my_disk_analp;

			     call tally_details_disk_;
			     if j = i + ndtstats
			     then call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, ltrim (analysis_string));
			     go to end_anal_display;
			     end;			/* end disk display */


			else if substr (stat.devname, 1, 3) = "prt" then do;

			     call analyze_detail_stat_ ((stat.devname), stat.status, (stat.detailed_status),
				my_prt_analp, code);
			     if code ^= 0 then go to end_anal_display;

			     prt_analp = my_prt_analp;
			     if prt_analysis.num_analyzed = 0 then go to end_anal_display;

			     call tally_details_prt_;

			     if j = i + ndtstats
			     then call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, ltrim (analysis_string));
			     go to end_anal_display;
			     end;			/* end prt display */

			else if substr (stat.devname, 1, 3) = "rdr" | substr (stat.devname, 1, 3) = "pun" then do;
			     call analyze_detail_stat_$rsnnl ((stat.devname), stat.status, (stat.detailed_status),
				msg, is_interesting, code);
			     if is_interesting then call ioa_ ("^vx^5d^3x^a", indent, stat.count, msg);

			     go to end_anal_display;
			     end;			/* end rdr_pun display */

end_anal_display:
			end;
		end;
		i = i + ndtstats;
		end;
	end;
	call ioa_ ("");
	return;

     end print_it;


%page;
convert_seek_addr:
     proc (sector, disk_name, chn_name, cyl_, hd_, sec_);

/* **********************************************************************
   *   given a seek address, this routine returns the sector, head and   *
   *   cylinder information from that address. High efficiency format    *
   *   is assumed.                      			   *
   ********************************************************************** */

dcl  (sector, sec_, sa, cyl_, hd_) fixed bin (24);
dcl  disk_name char (8) aligned;
dcl  chn_name char (8) aligned;
dcl  (dev_idx, i, j) fixed bin;
dcl  (dev_model, dev_no_index, dev_no) fixed bin;
dcl  iom_number fixed bin (3);
dcl  chn_number fixed bin (6);

	cyl_ = -1;
	hd_ = -1;
	sec_ = -1;

	do i = 1 to hbound (dev_idx_list, 1) while (dev_idx_list (i).valid);
	     if dev_idx_list (i).device_name = disk_name then goto calc;
	end;

	if i > hbound (dev_idx_list, 1) then i = hbound (dev_idx_list, 1);
	dev_idx_list (i).valid = "1"b;
	dev_idx_list (i).device_name = disk_name;
	dev_idx_list (i).device_idx = 0;

/* Determine the model of the drive  */

	dev_no_index, dev_model = 0;
	dev_no = cv_dec_check_ (substr (disk_name, 6, 2), code);

	call config_$find_periph (substr (disk_name, 1, 4), prph_dsk_cardp);
						/* will need drive no. later */
	if prph_dsk_cardp = null () then return;

	if chn_sw then do;
	     call parse_io_channel_name_ ((chn_name), iom_number, chn_number, code);
	     call find_controller (iom_number, (chn_number));
	     end;
	else call find_controller (prph_dsk_card.iom, prph_dsk_card.chan);

	if mpc_cardp = null () & ^fips_controller then return;

	do j = 1 to 5 while (dev_model = 0);
	     dev_no_index = dev_no_index + prph_dsk_card.ndrives (j);
	     if dev_no < dev_no_index | (^fips_controller & dev_no = dev_no_index)
	     then dev_model = prph_dsk_card.model (j);
	end;
	if dev_model = 0 then goto calc;		/* device not found */

	do j = 1 to hbound (MODEL, 1) while (dev_idx_list (i).device_idx = 0);
	     if dev_model = MODEL (j) then dev_idx_list (i).device_idx = MODELX (j);
	end;

calc:
	dev_idx = dev_idx_list (i).device_idx;
	if dev_idx < 2 then return;

	sa = divide (sector, sect_per_track (dev_idx), 24, 0);
	sec_ = mod (sector, sect_per_track (dev_idx));
	cyl_ = divide (sa, tracks_per_cyl (dev_idx), 24, 0);
	hd_ = mod (sa, tracks_per_cyl (dev_idx));

	return;
     end convert_seek_addr;
%page;
/* Cleanup handler */

clean_up:
     proc;

	call syserr_log_util_$close (code);

	if sortp ^= null () then call release_temp_segment_ (name, sortp, code);
	if areap ^= null () then call release_area_ (areap);

	return;

     end clean_up;
%page;
pick_status_table:
     proc;

	if substr (stat.devname, 1, 3) = "tap" then stat_tablep = addr (tape_status_table_$tape_status_table_);
	else if substr (stat.devname, 1, 3) = "prt" then stat_tablep = addr (prt_status_table_$prt_status_table_);
	else if substr (stat.devname, 1, 3) = "rdr" then stat_tablep = addr (crz_status_table_$crz_status_table_);
	else if substr (stat.devname, 1, 3) = "pun" then stat_tablep = addr (cpz_status_table_$cpz_status_table_);
	else if substr (stat.devname, 1, 3) = "dsk" then do;
	     if fips_disk (stat.devname)
	     then stat_tablep = addr (fdisk_status_table_$fdisk_status_table_);
	     else stat_tablep = addr (disk_status_table_$disk_status_table_);
	     end;
	else if substr (stat.devname, 1, 3) = "opc" then stat_tablep = addr (opc_status_table_$opc_status_table_);
	else stat_tablep = null;

	return;

     end pick_status_table;
%page;

/* This routine will determine the type of MPC and MTH we are dealing with,
   and then it will mask off meaningless certain bits in the detailed status
   depending on the type of IO error so that the detail status can be sorted
   properly. */

process_tape_status:
     proc;

dcl  mth_type fixed bin;
dcl  iom_number fixed bin (3);
dcl  chn_number fixed bin (6);

	call config_$find_periph (substr (stat.devname, 1, 4), prph_tap_cardp);
	if prph_tap_cardp = null () then return;

	if chn_sw then do;
	     call parse_io_channel_name_ ((stat.chnname), iom_number, chn_number, code);
	     call find_controller (iom_number, (chn_number));
	     end;
	else call find_controller (prph_tap_card.iom, (prph_tap_card.chan));

	if fips_controller then do;
	     stat.detailed_status = stat.detailed_status & fips_tape_mask;
	     return;
	     end;

	if mpc_cardp = null () then return;
	mpc_model = mpc_card.model;

/* Now determine the MTH type */

	if substr (stat.detailed_status, 27, 1) = "0"b then mth_type = 500;
	else if substr (stat.detailed_status, 53, 4) = "4"b4 then mth_type = 600;
	else if substr (stat.detailed_status, 53, 4) = "8"b4 then mth_type = 610;
	else if substr (stat.detailed_status, 53, 4) = "6"b4 then mth_type = 640;


	if mpc_model = 501 | mpc_model = 502 | mpc_model = 600
	then stat.detailed_status = stat.detailed_status & mtc500_mask;

	else if mpc_model = 601 | mpc_model = 602 then stat.detailed_status = stat.detailed_status & mtp601_mask;

	else if mpc_model = 610 | mpc_model = 611 then do;
	     stat.detailed_status = stat.detailed_status & mtp610_mask;

	     if substr (stat.detailed_status, 17, 1) = "1"b
	     then					/* If NRZI then.. */
		stat.detailed_status =
		     stat.detailed_status & "ffffffffffffffffffffffffffffffffff80ffff008264ff0000"b4;

	     else if substr (stat.detailed_status, 17, 3) = "0"b
	     then					/* if PE (1600) */
		stat.detailed_status =
		     stat.detailed_status & "ffffffffffffffffffffffffffffffffff800000008267ff0000"b4;
	     else if substr (stat.detailed_status, 17, 3) = "001"b then do;
						/* if GCR (6250) */
		stat.detailed_status =
		     stat.detailed_status & "ffffffffffffffffffffffffffffffffff8000fff20000ff00ff"b4;
		if substr (stat.detailed_status, 10, 1) = "1"b
		then				/* if write op */
		     substr (stat.detailed_status, 158, 1) = "0"b;

		else if substr (stat.detailed_status, 10, 1) = "0"b
		then				/* if read op */
		     substr (stat.detailed_status, 156, 2) = "0"b;
		end;
	     end;

	if mth_type = 500 then stat.detailed_status = stat.detailed_status & mth500_mask;

	else if mth_type = 600 then stat.detailed_status = stat.detailed_status & mth600_mask;

	else if mth_type = 610 then stat.detailed_status = stat.detailed_status & mth610_mask;

	else if mth_type = 640 then stat.detailed_status = stat.detailed_status & mth640_mask;

	if tdbie_sw = "0"b
	then					/* mask off data bit in err data */
	     stat.detailed_status = stat.detailed_status & "ffffffffffffffffffffffffffffffff001fffffffffffffffff"b4;


	return;
     end process_tape_status;

%page;
process_prt_status:
     proc (prt_name);

dcl  prt_name char (8);
dcl  ptr_model fixed bin;



	if substr (stat.status, 1, 12) = "4201"b3 then do;/* Paper out ? */
	     stat.detailed_status = "0"b;
	     return;
	     end;


/*  Scan the config deck to determine the type of prt we are working on  */


	call config_$find_periph (substr (prt_name, 1, 4), prph_cardp);
	if prph_cardp = null () then return;
	ptr_model = prph_card.model;

	if substr (stat.status, 1, 12) = "4310"b3 then do;/* Paper low ? */
	     if ptr_model = 1200 | ptr_model = 1600
	     then if substr (stat.detailed_status, 61, 1) = "1"b then do;
		     stat.detailed_status = "0"b;
		     return;
		     end;

	     if ptr_model = 901 | ptr_model = 1000 | ptr_model = 1201
	     then if substr (stat.detailed_status, 97, 8) = "09"b4 then do;
		     stat.detailed_status = "0"b;
		     return;
		     end;
	     end;

	if ptr_model = 1200 | ptr_model = 1600 then do;
	     if substr (stat.status, 1, 12) = "4302"b3 |	/* if alrt bef/aftr print */
		substr (stat.status, 1, 12) = "4304"b3 then do;
						/* see if we need to mask off echo ck data */
						/* ECHO CHECK ?? */
		if fixed (substr (stat.detailed_status, 41, 2), 2) > 0
		then				/*  no mask */
		     return;

/* SHORT CKT */
		if fixed (substr (stat.detailed_status, 81, 2), 2) > 0
		then				/*  no mask */
		     return;

		end;				/*  mask off echo check short ckt ctrs */

	     stat.detailed_status = stat.detailed_status & pr71_mask;
	     end;

	else if ptr_model = 901 | ptr_model = 1000 | ptr_model = 1201
	then stat.detailed_status = stat.detailed_status & pr54_mask;
	return;
     end process_prt_status;

%page;
tally_details_disk_:
     proc;
dcl  temp1 char (256) var init ("");
dcl  cur_analysis char (256) var;
dcl  ca_port_str char (50) var init ("");
dcl  ret_str_len fixed bin;

	call ioa_$rsnnl ("^[^2s^;CA ^1o, Port ^2d^/^]", ca_port_str, ret_str_len, disk_analysis.fips_controller,
	     disk_analysis.CA, disk_analysis.PORT);

	if analysis_string = "" then do;		/* first time here for this status */
	     display_detail_count = display_detail_count + stat.count;
	     if disk_analysis.is_interesting_disk
	     then call ioa_$rs ("^vx^8x^v(^a ^)", temp1, analysis_char_count, indent, disk_analysis.num_analyzed,
		     disk_analysis.analyses);
	     analysis_string = ca_port_str || rtrim (temp1);

	     return;
	     end;

	if disk_analysis.is_interesting_disk
	then call ioa_$rs ("^vx^8x^v(^a ^)", temp1, analysis_char_count, indent, disk_analysis.num_analyzed,
		disk_analysis.analyses);

	cur_analysis = ca_port_str || rtrim (temp1);

	if unspec (analysis_string) ^= unspec (cur_analysis) then do;
	     call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, ltrim (analysis_string));
	     analysis_string = cur_analysis;
	     display_detail_count = stat.count;
	     unspec (cur_analysis) = "0"b;
	     return;
	     end;
	else display_detail_count = display_detail_count + stat.count;

	return;
     end tally_details_disk_;

%page;
tally_details_prt_:
     proc;
dcl  temp1 char (50) var init ("");
dcl  temp2 char (256) var init ("");
dcl  cur_analysis char (256) var;


	if analysis_string = "" then do;		/* first time here for this status */
	     display_detail_count = display_detail_count + stat.count;

	     if prt_analysis.density ^= ""
	     then call ioa_$rs ("^vx^8x^a", temp1, analysis_char_count, indent, prt_analysis.density);
	     call ioa_$rs ("^vx^8x^v(^a ^)", temp2, analysis_char_count, indent, prt_analysis.num_analyzed,
		prt_analysis.analyses);

	     analysis_string = rtrim (temp1) || rtrim (temp2);

	     return;
	     end;

	if prt_analysis.density ^= ""
	then call ioa_$rs ("^vx^8x^a", temp1, analysis_char_count, indent, prt_analysis.density);
	call ioa_$rs ("^vx^8x^v(^a ^)", temp2, analysis_char_count, indent, prt_analysis.num_analyzed,
	     prt_analysis.analyses);

	cur_analysis = rtrim (temp1) || rtrim (temp2);

	if unspec (analysis_string) ^= unspec (cur_analysis) then do;
	     call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, ltrim (analysis_string));
	     analysis_string = cur_analysis;
	     display_detail_count = stat.count;
	     unspec (cur_analysis) = "0"b;
	     return;
	     end;
	else display_detail_count = display_detail_count + stat.count;

	return;
     end tally_details_prt_;

%page;
tally_details_tape_:
     proc;
dcl  (temp1, tracks_hdr, tracks_str) char (150) var init ("");
dcl  temp2 char (256) var init ("");
dcl  cur_analysis char (256) var;
dcl  (i, tracks) fixed bin;
dcl  dbie_7track (7) fixed bin;

	if analysis_string = "" then do;		/* first time here for this status */
	     call ioa_$rs ("Operation: ^a, Density: ^d Tracks: ^d", temp1, analysis_char_count, tape_analysis.operation,
		tape_analysis.density, tape_analysis.num_tracks);

	     if tdbie_sw then do;
		if null_tape_tracks ^= tape_analysis.tracks_in_error then do;
		     tracks = tape_analysis.num_tracks;
		     call ioa_$rs ("^[^a^;^s^]^[^a^;^s^]", tracks_hdr, analysis_char_count, (tracks = 9), db_trk_str9,
			(tracks = 7), db_trk_str7);
		     do i = 1 to 9;
			if tape_analysis.dbie_array (i) ^= 0
			then dbie_counts (i) = tape_analysis.dbie_array (i) * stat.count;
		     end;
		     if tracks = 9
		     then call ioa_$rs ("^vx^6xError Count:  ^v(^4d ^)", tracks_str, analysis_char_count, indent, 9,
			     dbie_counts);

		     else do;			/* convert array */
			do i = 3 to 9;
			     dbie_7track (i - 3) = dbie_counts (i);
			end;
			call ioa_$rs ("^vx^6xError Count:  ^v(^4d ^)", tracks_str, analysis_char_count, indent, 7,
			     dbie_7track);
			end;

		     end;
		end;

	     if tape_analysis.num_analyzed > 0
	     then call ioa_$rsnnl ("^vx^8x^v(^a ^)", temp2, analysis_char_count, indent, tape_analysis.num_analyzed,
		     tape_analysis.analyses);

	     analysis_string = rtrim (temp1) || rtrim (temp2);
	     track_analysis = rtrim (tracks_hdr) || rtrim (tracks_str);
	     display_detail_count = stat.count;
	     return;
	     end;

	call ioa_$rs ("Operation: ^a, Density: ^d Tracks: ^d", temp1, analysis_char_count, tape_analysis.operation,
	     tape_analysis.density, tape_analysis.num_tracks);

	if tdbie_sw then do;
	     if null_tape_tracks ^= tape_analysis.tracks_in_error then do;

		tracks = tape_analysis.num_tracks;
		call ioa_$rs ("^[^a^;^s^]^[^a^;^s^]", tracks_hdr, analysis_char_count, (tracks = 9), db_trk_str9,
		     (tracks = 7), db_trk_str7);
		do i = 1 to 9;
		     if tape_analysis.dbie_array (i) ^= 0
		     then dbie_counts (i) = dbie_counts (i) + (tape_analysis.dbie_array (i) * stat.count);
		end;
		if tracks = 9
		then call ioa_$rs ("^vx^6xError Count:  ^v(^4d ^)", tracks_str, analysis_char_count, indent, 9,
			dbie_counts);

		else do;				/* convert array */
		     do i = 3 to 9;
			dbie_7track (i - 3) = dbie_counts (i);
		     end;
		     call ioa_$rs ("^vx^6xError Count:  ^v(^4d ^)", tracks_str, analysis_char_count, indent, 7,
			dbie_7track);
		     end;

		end;
	     end;

	if tape_analysis.num_analyzed > 0
	then call ioa_$rsnnl ("^vx^8x^v(^a ^)", temp2, analysis_char_count, indent, tape_analysis.num_analyzed,
		tape_analysis.analyses);

	cur_analysis = rtrim (temp1) || rtrim (temp2);
	track_analysis = rtrim (tracks_hdr) || rtrim (tracks_str);
	if unspec (analysis_string) ^= unspec (cur_analysis) then do;
	     call ioa_ ("^vx^5d^3x^a", indent, display_detail_count, analysis_string);
	     analysis_string = cur_analysis;
	     display_detail_count = stat.count;
	     return;
	     end;
	else display_detail_count = display_detail_count + stat.count;

	return;
     end tally_details_tape_;
%page;
find_controller:
     proc (a_iom, a_chan);
dcl  a_iom fixed bin (3);
dcl  a_chan fixed bin (8);

	fips_controller = "0"b;
	ipc_cardp = null ();
	mpc_cardp = null ();
	do while ("1"b);
	     call config_$find ("mpc", mpc_cardp);
	     if mpc_cardp = null () then goto check_for_fips;
	     do i = 1 to hbound (mpc_card.port, 1) while (mpc_card.port (i).iom ^= -1);
		if (a_iom = mpc_card.port (i).iom) & (a_chan >= mpc_card.port (i).chan)
		     & (a_chan < mpc_card.port (i).chan + mpc_card.port (i).nchan)
		then return;
	     end;
	end;

check_for_fips:
	do while ("1"b);
	     call config_$find ("ipc", ipc_cardp);
	     if ipc_cardp = null () then return;
	     if (a_iom = ipc_card.iom) & (a_chan >= ipc_card.chan) & (a_chan < ipc_card.chan + ipc_card.nchan) then do;
		fips_controller = (ipc_card.type = "fips");
		return;
		end;
	end;
     end find_controller;
%skip (4);
fips_disk:
     proc (disk_name) returns (bit (1));

dcl  disk_name char (8) aligned;
dcl  i fixed bin;


	do i = 1 to hbound (disk_list, 1) while (disk_list (i).valid);
	     if disk_list (i).device_name = disk_name then return (disk_list (i).fips);
	end;

	if i > hbound (disk_list, 1) then i = hbound (disk_list, 1);
	disk_list (i).valid = "1"b;
	disk_list (i).device_name = disk_name;
	disk_list (i).fips = ""b;

	call config_$find_periph (substr (disk_name, 1, 4), prph_dsk_cardp);
	if prph_dsk_cardp = null () then return (""b);

	call find_controller (prph_dsk_card.iom, prph_dsk_card.chan);

	disk_list (i).fips = fips_controller;
	return (fips_controller);
     end fips_disk;
%page;
%include syserr_message;
%page;
%include io_syserr_msg;
%page;
%include iom_stat;
%page;
%include syserr_binary_def;
%page;
%include area_info;
%page;
%include analyze_det_stat_info;
%page;
%include config_prph_tap_card;
%page;
%include config_prph_dsk_card;
%page;
%include config_prph_card;
%page;
%include fs_dev_types;
%page;
%include config_ipc_card;
%page;
%include config_mpc_card;
%page;
%include access_mode_values;


     end io_error_summary;




		    ips_mask_commands.pl1           08/27/84  1443.8rew 08/22/84  1220.6       78201



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

/* format: style3 */

get_ips_mask:
     proc () options (variable);

/* DESCRIPTION:
   Utility commands for manipulating IPS masks.
*/

/* HISTORY:
Written by W. Olin Sibert, 02/16/80.
Modified:
07/16/84 by R. Michael Tague:  To work work 32 char IPS signal names.
*/


/* START OF DECLARATIONS */

dcl	(argno, nargs)	fixed bin;
dcl	al		fixed bin (21);
dcl	ap		pointer;
dcl	arg		char (al) based (ap);
dcl	code		fixed bin (35);
dcl	whoami		char (32);
dcl	(brief_sw, all_sw)	bit (1) aligned;

dcl	(old_mask, new_mask, current_mask)
			bit (36) aligned;
dcl	temp_mask		bit (36) aligned;
dcl	mask_string	char (1188) varying;	/* 35 signals * 32 char names
			           + (35-1) * length(", ") */

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	hcs_$get_ips_mask	entry (bit (36) aligned);
dcl	hcs_$reset_ips_mask entry (bit (36) aligned, bit (36) aligned);
dcl	ioa_		entry options (variable);
dcl	ioa_$nnl		entry options (variable);
dcl	ioa_$rsnnl	entry options (variable);

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

dcl	1 sys_info$ips_mask_data
			aligned external static,
	  2 count		fixed bin,
	  2 masks		(35),
	    3 name	char (32) aligned,
	    3 mask	bit (35) aligned;

dcl	ALL_IPS_MASK	bit (36) aligned internal static options (constant) init ("000000000000"b3);
dcl	NO_IPS_MASK	bit (36) aligned internal static options (constant) init ("777777777777"b3);
dcl	LAST_MASK_BIT	bit (36) aligned internal static options (constant) init ("000000000001"b3);

dcl	(addr, copy, substr, rel, bit, binary, null)
			builtin;

/* END OF DECLARATIONS */
%page;

/* get_ips_mask: proc () options (variable) */

	whoami = "get_ips_mask";			/* this entry prints the current list of masked signals */
	brief_sw = "0"b;

	call cu_$arg_count (nargs);
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));

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

	     else do;
BADOPT:
		     call com_err_ (error_table_$badopt, whoami, "^a", arg);
		     goto MAIN_RETURN;
		end;
	end;					/* of this argument loop */

	call hcs_$get_ips_mask (current_mask);

	call get_mask_string (current_mask);

	current_mask = current_mask & (^LAST_MASK_BIT);	/* turn off last bit, for ease of comuptation */
	if brief_sw
	then do;					/* print the masked signals in brief format */
		if current_mask = ALL_IPS_MASK
		then call ioa_ ("All IPS signals masked.");
		else if mask_string ^= ""
		then call ioa_ ("^a", mask_string);
	     end;

	else do;
		if current_mask = ALL_IPS_MASK
		then call ioa_ ("All IPS signals are masked.");
		else if mask_string ^= ""
		then /* if anything is masked, print it */
		     call ioa_ ("Masked IPS signals: ^a.", mask_string);
		else call ioa_ ("No IPS signals are masked.");
	     end;

MAIN_RETURN:
	return;					/* end of code for get_ips_mask */

/*  */

reset_ips_mask:
     entry () options (variable);

	whoami = "reset_ips_mask";			/* this entry resets specified masks or all masks */
	goto SET_IPS_MASK_COMMON;


set_ips_mask:
     entry () options (variable);

	whoami = "set_ips_mask";			/* this entry masks signals -- either those specified or all */
	goto SET_IPS_MASK_COMMON;


SET_IPS_MASK_COMMON:
	brief_sw = "0"b;
	all_sw = "0"b;

	new_mask = NO_IPS_MASK;

	call cu_$arg_count (nargs);
	do argno = 1 to nargs;
	     call cu_$arg_ptr (argno, ap, al, (0));

	     if substr (arg, 1, 1) ^= "-"
	     then do;				/* a signal name */
		     temp_mask = get_mask_bit (arg);	/* find out what bit to turn off */
		     if temp_mask = NO_IPS_MASK
		     then do;
			     call com_err_ (0, whoami, "Unknown IPS signal ""^a"".", arg);
			     goto MAIN_RETURN;
			end;

		     new_mask = new_mask & temp_mask;	/* turn off the corresponding bit */
		end;

	     else if arg = "-brief" | arg = "-bf"
	     then brief_sw = "1"b;
	     else if arg = "-long" | arg = "-lg"
	     then brief_sw = "0"b;
	     else if arg = "-all" | arg = "-a"
	     then all_sw = "1"b;

	     else goto BADOPT;
	end;					/* of this argument loop */

	if all_sw & (new_mask ^= NO_IPS_MASK)
	then do;
		call com_err_ (error_table_$inconsistent, whoami, "-all and any signal names.");
		goto MAIN_RETURN;
	     end;

	if (^all_sw) & (new_mask = NO_IPS_MASK)
	then do;
		call com_err_ (error_table_$noarg, whoami, "^/^5xUsage:^3x^a signal_name(s)|-all {-brief}", whoami);
		goto MAIN_RETURN;
	     end;

	if all_sw
	then new_mask = ALL_IPS_MASK;			/* if we're to mask them all, get all zero bits */

	call hcs_$get_ips_mask (current_mask);

	if whoami = "reset_ips_mask"
	then /* complement mask bits and set new ones to 1 */
	     new_mask = current_mask | (^new_mask);	/* turn all bits in the mask as specified */
	else new_mask = current_mask & new_mask;	/* otherwise, turn off specified bits in current_mask */

	call hcs_$reset_ips_mask (new_mask, (""b));	/* set it */

	current_mask = current_mask & (^LAST_MASK_BIT);	/* turn off last bit, for ease of comuptation */
	if ^brief_sw
	then do;					/* and print the results, if desired */
		call get_mask_string (current_mask);

		if current_mask = ALL_IPS_MASK
		then call ioa_ ("All IPS signals were previously masked.");
		else if mask_string ^= ""
		then /* if anything is masked, print it */
		     call ioa_ ("Previously masked IPS signals: ^a.", mask_string);
		else call ioa_ ("No IPS signals were previously masked.");
	     end;

	goto MAIN_RETURN;

/*  */

get_mask_string:
     proc (P_mask);

/* *	This procedure sets mask_string according to the signals indicated as masked
   *	in P_mask. P_mask is assumed to be in the normal format; that is, a "1" bit
   *	indicates that the corresponding signal is NOT masked. */

dcl	P_mask		bit (36) aligned parameter;

dcl	idx		fixed bin;
dcl	(all_on, all_off)	bit (1) aligned;
dcl	all_masks		bit (36);
dcl	temp_mask		bit (36) aligned;
dcl	temp_str		char (50) varying;

	mask_string = "";
	temp_mask = P_mask & (^LAST_MASK_BIT);		/* turn off last bit, of course */
	all_masks = ""b;

	do idx = 1 to sys_info$ips_mask_data.count;
	     if ((^temp_mask) & sys_info$ips_mask_data.mask (idx)) ^= ""b
	     then do;				/* found one with the right bit */
		     if length (mask_string) > 0
		     then /* format real pretty now */
			mask_string = mask_string || ", ";

		     mask_string = mask_string || rtrim (sys_info$ips_mask_data.name (idx));
						/* and add the signal name */
		end;

	     all_masks = all_masks | sys_info$ips_mask_data.mask (idx);
	end;

/* At this point, a bit will be set in all_masks for each valid mask, and temp_mask will have
   a zero for all masked signals. */

	all_on, all_off = "1"b;

	do idx = 1 to 35;
	     if substr (all_masks, idx, 1) = "0"b
	     then do;				/* not a defined mask */
		     if substr (temp_mask, idx, 1) = "0"b
		     then all_on = "0"b;		/* keep a pair of bits describing the state of all */
		     else all_off = "0"b;		/* the nonstandard signals */
		end;
	end;

	if ^(all_on | all_off)
	then do;					/* something nonstandard */
		if length (mask_string) > 0
		then /* add formatting, regardless */
		     mask_string = mask_string || ", ";

		call ioa_$rsnnl ("<undefined signals: ^w>", temp_str, (0), temp_mask);
		mask_string = mask_string || temp_str;
	     end;

	return;

     end get_mask_string;

/*  */

get_mask_bit:
     proc (P_name) returns (bit (36) aligned);

/* *	This procedure returns a bit string to mask the named signal; the bit
   *	string is in the normal format, such that all bits will be "1"b except
   *	for the one indicating the specified signal. If the named signal does not
   *	exist, the returned mask will be equal to NO_IPS_MASK. */

dcl	P_name		char (*) parameter;

dcl	mask		bit (36) aligned;
dcl	idx		fixed bin;

	mask = NO_IPS_MASK;

	do idx = 1 to sys_info$ips_mask_data.count;
	     if P_name = sys_info$ips_mask_data.name (idx)
	     then do;
		     mask = ^sys_info$ips_mask_data.mask (idx);
		     return (mask);			/* found it */
		end;
	end;

	return (mask);
     end get_mask_bit;

     end get_ips_mask;





		    opc_status_table_.alm           09/12/83  1116.3rew 09/12/83  1032.4       14256



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" OPC_STATUS_TABLE_ - Status Tables for Operator's Console
"	coded August 1976 by Larry Johnson
"	modified 4/79 by R.J.C. Kissel to add major status 0.

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


	include	status_table

"

	status_table	opc,(1,0,1,1,0,1,0,0,0,0,0,0,0,0,0,0)

"
	status_entry	1,(Channel Ready)

	substat_entry	1,000000,,(No substatus)

"

	status_entry	3,(Device Attention)

	substat_entry	3,000000,0,()

"

	status_entry	4,(Data Alert)

	substat_entry	4,000000,0,(Transfer timing error)
	substat_entry	4,0X0010,0,(Transmission parity error)
	substat_entry	4,000100,0,(Operator input error)
	substat_entry	4,001000,0,(Operator distracted)
	substat_entry	4,0100X0,0,(Incorrect format)
	substat_entry	4,100000,0,(Message length alert)

"

	status_entry	6,(Command Reject)

	substat_entry	6,000001,0,(Invalid instruction code)


	end




		    tape_status_table_.alm          09/12/83  1116.3rew 09/12/83  1027.6       38907



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1982 *
" *                                                         *
" ***********************************************************
" TAPE_STATUS_TABLE - Status Tables for Magnetic Tape.
"	coded 12/2/74 by Noel I. Morris
"	modified 4/79 by R.J.C. Kissel to add major status 0, and use alm macros.
"	modified 10/80 by R.L. Coppola to define the TCA for TCA malfunction status.

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


	include	status_table


" 
"  The 1's and 0's in the second argument to the status_table macro correspond
"  to the major statuses which will be in the generated table.

	status_table	tape,(1,1,1,1,1,1,0,0,0,0,1,1,0,1,0,0)

"

	status_entry	1,(Device Ready)
	
	substat_entry	1,000000,,(Ready)
	substat_entry	1,XX0XX1,,(Write protected)
	substat_entry	1,000X1X,,(Positioned at BOT)
	substat_entry	1,XXX1XX,,(Nine track handler)
	substat_entry	1,010X0X,,(Two bit fill)
	substat_entry	1,100X0X,,(Four bit fill)
	substat_entry	1,110X0X,,(Six bit fill)
	substat_entry	1,001100,,(ASCII alert)

" 

	status_entry	2,(Device Busy)

	substat_entry	2,000001,,(Tape rewinding)
	substat_entry	2,100000,,(Device reserved)
	substat_entry	2,000010,,(Alternate channel in control)
	substat_entry	2,000100,,(Device loading)

" 

	status_entry	3,(Device Attention)

	substat_entry	3,00XX01,,(Write protected)
	substat_entry	3,000010,,(No such tape handler)
	substat_entry	3,0XX10X,,(Handler in standby)
	substat_entry	3,0X1X0X,,(Handler check)
	substat_entry	3,01XX00,,(Blank tape on write)

" 

	status_entry	4,(Device Data Alert)

	substat_entry	4,000001,,(Transfer timing alert)
	substat_entry	4,000010,,(Blank tape on read)
	substat_entry	4,XXXX11,,(Bit detected during erase)
	substat_entry	4,XXX1XX,,(Transmission parity alert)
	substat_entry	4,XX1XXX,,(Lateral parity alert)
	substat_entry	4,X1XXXX,,(Longitudinal parity alert)
	substat_entry	4,1XXXXX,,(End of tape mark detected)

" 

	status_entry	5,(End of File)

	substat_entry	5,001111,,(7 track EOF)
	substat_entry	5,010011,,(9 track EOF)
	substat_entry	5,111111,,(Data alert condition)

" 

	status_entry	6,(Command Reject)

	substat_entry	6,000000,,(Invalid density)
	substat_entry	6,000XX1,,(Invalid operation code)
	substat_entry	6,000X1X,,(Invalid device code)
	substat_entry	6,0001XX,,(Invalid IDCW parity)
	substat_entry	6,001000,,(Positioned at BOT)
	substat_entry	6,010000,,(Forward read after write)
	substat_entry	6,100000,,(Nine track error)

" 

	status_entry	11,(MPC Attention)

	substat_entry	11,000001,,(Configuration switch error)
	substat_entry	11,000010,,(Multiple devices)
	substat_entry	11,000011,,(Illegal device number)
	substat_entry	11,001000,,(Incompatible mode)
	substat_entry	11,001100,,(TCA malfunction (0))
	substat_entry	11,001101,,(TCA malfunction (1))
	substat_entry	11,010000,,(MTH malfunction)
	substat_entry	11,010001,,(Multiple BOT)

" 

	status_entry	12,(MPC Data Alert)

	substat_entry	12,000001,,(Transmission parity alert)
	substat_entry	12,000010,,(Inconsistent command)
	substat_entry	12,000011,,(Sum check error)
	substat_entry	12,000100,,(Byte locked out)
	substat_entry	12,001000,,(ID Burst write error)
	substat_entry	12,001001,,(Preamble error)
	substat_entry	12,001010,,(T&D error)
	substat_entry	12,010000,,(Multi-track error)
	substat_entry	12,010001,,(Skew error)
	substat_entry	12,010010,,(Postamble error)
	substat_entry	12,010011,,(NRZI CCC error)
	substat_entry	12,010100,,(Code alert)
	substat_entry	12,100000,,(Marginal condition)

" 

	status_entry	14,(MPC Command Reject)

	substat_entry	14,000001,,(Illegal procedure)
	substat_entry	14,000010,,(Illegal logical channel)
	substat_entry	14,000011,,(Illegal suspended logical chnnl)
	substat_entry	14,000100,,(Continue bit not set)



	end




		    test_dcw.pl1                    07/18/86  1505.2rew 07/18/86  1230.0      564894



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




/****^  HISTORY COMMENTS:
  1) change(86-06-04,Hartogs), approve(86-06-04,MCR7383),
     audit(86-06-05,Coppola), install(86-07-18,MR12.0-1098):
     Changed to user version constants in rcp_disk_info.incl.pl1,
     rcp_device_info.incl.pl1, and rcp_printer_info.incl.pl1.
                                                   END HISTORY COMMENTS */


/* TEST_DCW: a program to build dcw lists to test an I/O device */

/* Written in bits and pieces from 1975 to March 1977 by Larry Johnson */
/* Modified August 1977 by Larry Johnson to automatically supply device address in idcws */
/* Modified December 1978 by Michael R. Jordan for version 2 tape info */
/* Modified January 1980 by Larry Johnson for get_detailed_status and get_spacial_status commands */

test_dcw: proc;

/* Automatic storage */

dcl  dcw_list (32, 32) bit (36);			/* A table of 32 different lists */
dcl  pcw_list (32) bit (36);				/* One PCW for each list */
dcl  list fixed bin init (1);				/* The "current" list */
dcl  idx fixed bin init (1);				/* Position in the current list */
dcl  dcw_len (32) fixed bin;				/* Length of each list */
dcl  input_line char (132);				/* A command line read from the terminal */
dcl  input_len fixed bin (21);			/* The actual length of that line */
dcl  input_pos fixed bin;				/* The current char position in scanning input_line */
dcl  word char (132);				/* A word extracted from the input line */
dcl  code fixed bin (35);				/* A standard system status code */
dcl  temp_char char (1);				/* To hold 1 character */
dcl (i, j) fixed bin;				/* A temporary index */
dcl  end_line bit (1);				/* Set when end of line reached */
dcl  octal_word bit (1);				/* Set if current word will convert to octal */
dcl  octal_val fixed bin (35);			/* Value of current word if converted to octal */
dcl  dec_word bit (1);				/* Set if word will convert to decimal */
dcl  dec_val fixed bin (35);				/* Value if convert to decimal */
dcl  insert_mode bit (1) init ("0"b);			/* Set if insert mode, reset if replace mode */
dcl  output_line char (128) var;			/* For building line to print */
dcl  out_temp char (64) var;				/* Temp area for building output strings */
dcl  pcw_sw bit (1);				/* Set if pcw is being built */
dcl  devx fixed bin init (-1);			/* Ioi device index */
dcl  exec_rept_cnt fixed bin;				/* Count of repeated executions */
dcl (dp_loc, dp_len, dp_rpt) fixed bin;			/* Indexes for dumps and patches */
dcl  dp_byte bit (1);				/* Set when dumping binary bytes */
dcl  arg_cnt fixed bin;				/* Number of command arguments */
dcl  arg_ptr ptr;					/* A pointer to a command argument */
dcl  arg_len fixed bin;				/* The length of that argument */
dcl  arg char (arg_len) based (arg_ptr);		/* Hence, this is the argument */
dcl  survey_ptr ptr;				/* Pointer to survey devices data */
dcl  time_limit fixed bin (52);			/* Connect time limit - 30 seconds initially */
dcl  dev_name char (16) varying;			/* This will be name of device assigned */
dcl  dev_type char (16) varying;			/* Generic device type */
dcl  id_name char (16) varying;			/* This will be the pack id or tape volume */
dcl  priv_sw bit (1) init ("0"b);			/* Will be 1 if -priv specified */
dcl  write_sw bit (1) init ("1"b);			/* Will be "0" if -read specified */
dcl  debug_sw bit (1) init ("0"b);			/* Set if -db used */
dcl  prompt_msg char (10) varying init ("");		/* Promt character for command input */
dcl  rcp_id bit (36) aligned init ("0"b);		/* RCP_ attachment id */
dcl  rcp_state fixed bin;				/* State code returned by rcp_$check_attach */
dcl  max_time fixed bin (71);				/* Max time limit for connects */
dcl  max_work fixed bin (19);				/* Max buffer size supported by ioi_ */
dcl  rcp_info_ptr ptr;				/* Pointer to the rcp info block being used */
dcl  sys_sw bit (1) init ("0"b);			/* Set if -sys control argument specified */
dcl  list_name (32) char (8);				/* Names of dcs lists */
dcl  new_name char (8);
dcl  dcw_word bit (36) aligned;			/* Dcws are built here */
dcl  something_printed bit (1);
dcl  track_sw bit (1) aligned init ("0"b);		/* "1"b if -7track specified */
dcl  exec_spec_sw bit (1);				/* Set when exec command requires special */
dcl  exec_no_err_sw bit (1);				/* Set when exec command to ignore error */
dcl  exec_rept_sw bit (1);				/* Set when executing in repeat mode */
dcl  iom fixed bin (3);				/* Required iom number if chan command used */
dcl  chan fixed bin (6);				/* Required channel if chan command used */
dcl  ptr_array (1) ptr init (null);			/* For get temp segments */
dcl  new_work_size fixed bin (18);
dcl  flush_sw bit (1);
dcl  dir char (168);
dcl  unsuffixed_ename char (32);
dcl  ename char (32);
dcl  time_string char (24);
dcl  status_tablep ptr;				/* Address of appropriate status table */
dcl  status_mode fixed bin init (1);			/* 1=brief, 2=long, 3=edited */
dcl  save_status_mode fixed bin;
dcl  default_device bit (6);				/* Device number to put in all idcws */
dcl  stat_found bit (1) aligned;
dcl  spec_status bit (36) aligned;
dcl  detailed_status bit (6*36);
dcl  detailed_status_array (1:27) bit (8) unal based (addr (detailed_status));

dcl 1 my_tape_info like tape_info aligned automatic;	/* Copy of rcp_tape_info in my stack */
dcl 1 my_disk_info like disk_info aligned automatic;	/* Copy of rcp_disk_info in my stack */
dcl 1 my_printer_info like printer_info aligned automatic;	/* Copy of rcp_printer_info in my stack */
dcl 1 my_device_info like device_info aligned automatic;	/* Copy of rcp_device_info in my stack */

/* Format of detailed status returned by mtc500 handler */

dcl  dtstp ptr;					/* Pointer to the structure */

dcl 1 dt_stat aligned based (dtstp),			/* The detailed status structure */
						/* ... Byte # 0 ... */
   (2 devflt bit (1),				/* Device Fault */
    2 ccerr bit (1),				/* Command code error */
    2 rawerr bit (1),				/* Read-after_write error */
    2 mbot bit (1),					/* Multiple BOTs */
    2 bot bit (1),					/* BOT */
    2 eot bit (1),					/* EOT */
    2 standby bit (1),				/* Standby state */
    2 marg bit (1),					/* Marginal condition */
						/* ... Byte # 1 ... */
    2 loaded bit (1),				/* Loaded (standby) */
    2 lcw bit (1),					/* Last command write */
    2 lcf bit (1),					/* Last command forward */
    2 rewind bit (1),				/* Rewinding */
    2 wpr bit (1),					/* Write permit ring */
    2 spr bit (1),					/* Software write permit */
    2 diag bit (1),					/* Diagnostic mode */
    2 ccpe bit (1),					/* Command code parity even */
						/* ... Byte # 2 ... */
    2 denr bit (3),					/* Density return */
    2 lowt bit (1),					/* Low threshold */
    2 denc bit (4),					/* Recording capability */
						/* ... Byte # 3 ... */
    2 speed bit (5),				/* Device speed */
    2 track bit (1),				/* 7/9 channel */
    2 nsbot bit (1),				/* Non-standard BOT */
    2 mbz1 bit (1),					/* Must be zero */
						/* ... Byte # 4 ... */
    2 dms bit (1),					/* Device multiple select */
    2 mbz2 bit (2),					/* Must be zero */
    2 addr bit (5)) unal;				/* Physical device address */

dcl  speed_constant (0:15) char (5) var int static options (constant) init ("16", "18.75", "24", "25", "35", "37.5",
     "45", "48", "70", "75", "80", "105", "120", "125", "150", "200");

dcl 1 survey_table (16) unaligned based (survey_ptr),	/* Tape data returned by survey devices */
   (2 pad1 bit (1),
    2 hand_resv bit (1),				/* Handler reserved */
    2 hand_op bit (1),				/* Handler operational */
    2 hand_ready bit (1),				/* Handler ready */
    2 hand_addr bit (5),				/* Handler address */
    2 pad2 bit (1),
    2 hand_speed bit (3),				/* Handler speed */
    2 hand_track bit (1),				/* 7/9 track code */
    2 hand_record bit (4)) unaligned;			/* Handler recording capability */

/* Ioi buffer area */

dcl  workp ptr;					/* Pointer to it */
dcl  work_size fixed bin (18) init (1024);		/* Size of segment */
dcl  work_seg (work_size) bit (36) aligned based (workp);	/* The ioi workspace buffer */
						/* Words 1 to 32 reserved for dcw list */
						/* Words 33 to 64 reserved for status queue */

dcl  byte_ptr ptr;					/* Pointer to bytes in work area */
dcl  nbytes fixed bin;				/* Number of bytes in question */

dcl 1 bin_bytes aligned based (byte_ptr),
    2 bbyte (nbytes) bit (8) unaligned;			/* An array of bytes */

dcl 1 event_list,					/* A list of ipc events */
    2 ev_count fixed bin init (1),			/* Always 1 entry */
    2 ev_chan fixed bin (71) init (-1);			/* And this is it */

dcl 1 event_info,					/* Structure returned by ipc */
    2 channel_id fixed bin (71),
    2 message fixed bin (71),
    2 sender bit (36),
    2 origin,
      3 dev_signal bit (18) unaligned,
      3 ring bit (18) unaligned,
    2 channel_index fixed bin;


/* Structure define a segment where test_dcw data is saved */

dcl  save_segp ptr init (null);

dcl 1 save_seg aligned based (save_segp),
    2 version fixed bin,
    2 code char (16),
    2 time fixed bin (71),
    2 pcw_list (32) bit (36) aligned,
    2 dcw_len (32) fixed bin,
    2 list_name (32) char (8),
    2 dcw_list (32, 32) bit (36) aligned;

dcl  save_seg_code char (16) int static options (constant) init ("*test_dcw data*");

%include ioi_stat;

/* Areas for handling status */

dcl 1 stat like istat aligned automatic;		/* Ioi_stat structure in my stack */
dcl 1 status_queue (4) like istat aligned based (sqptr);	/* Status queue in ioi buffer */
dcl  sqptr ptr;					/* Pointer to status queue */
dcl  status_index fixed bin;				/* Current status queue entry */


%include iom_stat;


%include rcp_tape_info;

%include rcp_disk_info;

%include rcp_printer_info;

%include rcp_resource_types;

%include rcp_device_info;

%include iom_pcw;
%include iom_dcw;

/* Constants */

dcl  new_line char (1) static init ("
");						/* A new_line character */
dcl  tab char (1) static init ("	");			/* A tab character */
dcl  cmd_name char (8) init ("test_dcw");		/* The name of this thing */

/* Entry constants */

dcl  com_err_ entry options (variable);
dcl  convert_ipc_code_ entry (fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  cv_dec_check_ entry (char (*), fixed bin) returns (fixed bin (35));
dcl  cv_oct_check_ entry (char (*), fixed bin) returns (fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  ioa_$nnl entry options (variable);
dcl  ioa_$rsnnl entry options (variable);
dcl  ioi_$connect entry (fixed bin, fixed bin, fixed bin (35));
dcl  ioi_$connect_pcw entry (fixed bin, fixed bin, bit (36), fixed bin (35));
dcl  ioi_$set_status entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
dcl  ioi_$timeout entry (fixed bin, fixed bin (52), fixed bin (35));
dcl  ioi_$workspace entry (fixed bin, ptr, fixed bin (18), fixed bin (35));
dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
dcl  ipc_$block entry (ptr, ptr, fixed bin (35));
dcl  ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$delete_ev_chn entry (fixed bin (71), fixed bin (35));
dcl  ipc_$read_ev_chn entry (fixed bin (71), fixed bin, ptr, fixed bin (35));
dcl  ipc_$drain_chn entry (fixed bin (71), fixed bin (35));
dcl  ioi_$release_devices entry (fixed bin, fixed bin (35));
dcl  ioi_$get_detailed_status entry (fixed bin, bit (1) aligned, bit (216), fixed bin (35));
dcl  ioi_$get_special_status entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl  ioi_$set_channel_required entry (fixed bin, fixed bin (3), fixed bin (6), fixed bin (35));
dcl  ioi_$suspend_devices entry (fixed bin, fixed bin (35));
dcl  rcp_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71),
     fixed bin, fixed bin (35));
dcl  rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl  rcp_priv_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl  get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35));
dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl  suffixed_name_$make entry (char (*), char (*), char (32), fixed bin (35));
dcl  date_time_ entry (fixed bin (71), char (*));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  adjust_bit_count_ entry (char (168), char (32), bit (1) aligned, fixed bin (24), fixed bin (35));
dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
dcl  parse_io_channel_name_ entry (char (*), fixed bin (3), fixed bin (6), fixed bin (35));

/* External symbols */

dcl  iox_$user_input ext pointer;
dcl  sys_info$max_seg_size ext fixed bin (18);

dcl  disk_status_table_$disk_status_table_ ext;
dcl  tape_status_table_$tape_status_table_ ext;
dcl  prt_status_table_$prt_status_table_ ext;
dcl  cpz_status_table_$cpz_status_table_ ext;
dcl  crz_status_table_$crz_status_table_ ext;
dcl  imp_status_table_$imp_status_table_ ext;

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

/* Built in functions */

dcl (addr, before, bin, binary, bit, clock, divide, hbound, length, max, min, null, string, substr, unspec) builtin;

dcl (cleanup, program_interrupt) condition;

/* Initialize some stuff first */

	dcw_list = "0"b;				/* Reset all dcw */
	pcw_list = "0"b;				/* Reset all pcws */
	dcw_len = 0;				/* And their lengths */
	list_name = "";				/* No lists have names */
	pcwp, idcwp, dcwp, tdcwp = addr (dcw_word);

	on cleanup call clean_up;

/* Scan argument list */

	call cu_$arg_count (arg_cnt);			/* First find out how many */
	dev_name = "";				/* Device is unknown now */
	id_name = "";				/* Pack or volume unknown */
	do i = 1 to arg_cnt;
	     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
	     if code ^= 0 then do;
		call com_err_ (code, cmd_name, "Arg ^d", i);
		go to quit;
	     end;
	     if substr (arg, 1, 1) ^= "-" then do;	/* If not control arg */
		if dev_name = "" then dev_name = arg;	/* If no device specified yet */
		else if id_name = "" then id_name = arg; /* May be id name */
		else do;
		     code = error_table_$request_not_recognized; /* Multiple devices */
arg_err:		     call com_err_ (code, cmd_name, "^a", arg);
		     go to quit;
		end;
	     end;
	     else if arg = "-priv" then priv_sw = "1"b;	/* If request for privileged attach */
	     else if arg = "-read" then write_sw = "0"b;	/* Switch to read-only mode */
	     else if arg = "-7tr" | arg = "-7track" then track_sw = "1"b;
	     else if arg = "-sys" then sys_sw = "1"b;
	     else if arg = "-debug" | arg = "-db" then debug_sw = "1"b;
	     else do;				/* Nothing else I recognize */
		code = error_table_$badopt;
		go to arg_err;
	     end;
	end;
	if dev_name = "" then dev_name = "tap";		/* Default device is tape */
	if debug_sw then do;
	     call get_temp_segments_ (cmd_name, ptr_array, code); /* Get segment for work area */
	     if code ^= 0 then do;
		call com_err_ (code, cmd_name, "Unable to allocate temp segment.");
		go to quit;
	     end;
	     workp = ptr_array (1);
	     max_work = sys_info$max_seg_size;
	     default_device = "0"b;
	     go to ready;
	end;

/* Now determine the device type to be assigned */

	if dev_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) | dev_name = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then /* Any tape, or any disk */
	     dev_type = dev_name;
	else if dev_name = "tap" then
	     dev_type, dev_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX);
	else if dev_name = "dsk" then			/* Alternate form of any disk */
	     dev_type, dev_name = DEVICE_TYPE (DISK_DRIVE_DTYPEX);
	else if dev_name = DEVICE_TYPE (PRINTER_DTYPEX) | dev_name = "prt" then /* Any printer */
	     dev_name, dev_type = DEVICE_TYPE (PRINTER_DTYPEX);
	else if dev_name = DEVICE_TYPE (READER_DTYPEX) | dev_name = "rdr" then /* Any reader */
	     dev_name, dev_type = DEVICE_TYPE (READER_DTYPEX);
	else if dev_name = DEVICE_TYPE (PUNCH_DTYPEX) | dev_name = "pun" then /* Any punch */
	     dev_name, dev_type = DEVICE_TYPE (PUNCH_DTYPEX);
	else if length (dev_name) > 3 then do;		/* May be specific device */
	     if substr (dev_name, 1, 3) = "prt" then	/* Specific printer */
		dev_type = DEVICE_TYPE (PRINTER_DTYPEX);
	     else if substr (dev_name, 1, 3) = "rdr" then /* Specific reader */
		dev_type = DEVICE_TYPE (READER_DTYPEX);
	     else if substr (dev_name, 1, 3) = "pun" then /* Specific punch */
		dev_type = DEVICE_TYPE (PUNCH_DTYPEX);
	     else if substr (dev_name, 1, 3) = "tap" then do; /* Specific tape */
		dev_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX);
		if length (dev_name) >= 7 then if substr (dev_name, 6, 2) = "00" then /* Tape mpc */
			dev_type = DEVICE_TYPE (SPECIAL_DTYPEX);
	     end;
	     else if substr (dev_name, 1, 3) = "dsk" then do; /* Specific disk */
		dev_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX);
		if length (dev_name) >= 7 then if substr (dev_name, 6, 2) = "00" then /* New form disk mpc */
			dev_type = DEVICE_TYPE (SPECIAL_DTYPEX);
	     end;
	     else dev_type = DEVICE_TYPE (SPECIAL_DTYPEX); /* Don't recognize it */
	end;
	else dev_type = DEVICE_TYPE (SPECIAL_DTYPEX);	/* Don't recognize it */

/* Now assign some device as specified in the command */

	call ipc_$create_ev_chn (ev_chan, code);	/* First, I need a channel for interrupts */
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, cmd_name, "Unable to create event channel");
	     go to quit;
	end;

	if dev_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then do; /* If tape requested */
	     tape_info_ptr = addr (my_tape_info);	/* Use my tape info block */
	     tape_info.version_num = tape_info_version_2; /* And initialize it */
	     tape_info.usage_time = 0;
	     tape_info.wait_time = 0;
	     tape_info.system_flag = sys_sw;
	     if dev_name = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then tape_info.device_name = ""; /* No specific drive requested */
	     else tape_info.device_name = dev_name;	/* Ask for specific name */
	     tape_info.model = 0;
	     if track_sw then tape_info.tracks = 7;	/* 7 track drive requested */
	     else tape_info.tracks = 9;
	     tape_info.density = "0"b;
	     tape_info.speed = "0"b;			/* And initialize this also */
	     tape_info.unused_qualifier = "0"b;
	     if id_name = "" then tape_info.volume_name = "scratch"; /* If no volume requested */
	     else tape_info.volume_name = id_name;	/* Otherwise, use name requested */
	     tape_info.write_flag = write_sw;
	     tape_info.position_index = 0;
	     rcp_info_ptr = tape_info_ptr;		/* This is info block to use */
	end;

	else if dev_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then do; /* If attaching a disk */
	     disk_info_ptr = addr (my_disk_info);	/* Get pointer to my disk info block */
	     disk_info.version_num = DISK_INFO_VERSION_1;
	     disk_info.usage_time = 0;
	     disk_info.wait_time = 0;
	     disk_info.model = 0;
	     disk_info.system_flag = sys_sw;
	     if dev_name = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then disk_info.device_name = ""; /* If any disk will do */
	     else disk_info.device_name = dev_name;	/* Use name requested */
	     if id_name = "" then disk_info.volume_name = "scratch"; /* Use scratch if no volume given */
	     else disk_info.volume_name = id_name;	/* Otherwise use what was requested */
	     disk_info.write_flag = write_sw;
	     rcp_info_ptr = disk_info_ptr;		/* This the rcp block being used */
	end;

	else if dev_type = DEVICE_TYPE (PRINTER_DTYPEX) then do;
	     printer_info_ptr = addr (my_printer_info);	/* Use my printer block */
	     printer_info.version_num = PRINTER_INFO_VERSION_1;
	     printer_info.usage_time = 0;
	     printer_info.wait_time = 0;
	     printer_info.system_flag = sys_sw;
	     if dev_name = DEVICE_TYPE (PRINTER_DTYPEX) then printer_info.device_name = ""; /* If any printer will do */
	     else printer_info.device_name = dev_name;
	     printer_info.model = 0;
	     printer_info.print_train = 0;
	     rcp_info_ptr = printer_info_ptr;		/* Remember control block address */
	end;

	else do;					/* Some other device type */
	     device_info_ptr = addr (my_device_info);	/* Use my device info block */
	     device_info.version_num = DEVICE_INFO_VERSION_1;
	     device_info.usage_time = 0;
	     device_info.wait_time = 0;
	     device_info.system_flag = sys_sw;
	     if dev_name = dev_type then device_info.device_name = ""; /* No special device requested */
	     else device_info.device_name = dev_name;
	     device_info.model = 0;
	     rcp_info_ptr = device_info_ptr;
	end;

/* The rcp control block has been set up, so now do the attachment */

	if priv_sw then				/* If privileged */
	     call rcp_priv_$attach ((dev_type), rcp_info_ptr, ev_chan, "", rcp_id, code); /* Do privileged attachment */
	else call rcp_$attach ((dev_type), rcp_info_ptr, ev_chan, "", rcp_id, code);
	if code ^= 0 then do;
dev_err:	     call com_err_ (code, cmd_name, "^a", dev_name);
	     go to quit;
	end;

rcp_loop:	call rcp_$check_attach (rcp_id, rcp_info_ptr, word, devx, max_work, max_time, rcp_state, code);
	if rcp_state = 3 then go to dev_err;		/* Fatal error occured */
	if rcp_state = 0 then go to begin;		/* Attachment succeeded */
	if rcp_state = 1 then do;			/* Short wait code */
	     if word ^= "" then			/* If comment from somebody */
		call ioa_ ("^a: RCP indicates short wait for attachment. ^a", cmd_name, word);
	     call ipc_$block (addr (event_list), addr (event_info), code); /* Wait for attachment */
	     if code ^= 0 then do;
		call convert_ipc_code_ (code);
		call com_err_ (code, cmd_name, "While waiting for attachment.");
		go to quit;
	     end;
	     go to rcp_loop;			/* Check attachment again */
	end;

	call com_err_ (0, cmd_name, "RCP indicates long wait for attachment. ^a", word);
	go to quit;				/* I don't want to wait */


begin:	if dev_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX) then dev_name = disk_info.device_name;
	else if dev_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then dev_name = tape_info.device_name;
	else if dev_type = DEVICE_TYPE (PRINTER_DTYPEX) then dev_name = printer_info.device_name;
	else dev_name = device_info.device_name;
	call ioa_ ("Device ^a assigned.", dev_name);

	if dev_type = DEVICE_TYPE (DISK_DRIVE_DTYPEX) | dev_type = DEVICE_TYPE (TAPE_DRIVE_DTYPEX) then default_device = bit (bin (substr (dev_name, 6, 2), 6), 6);
	else if dev_type = DEVICE_TYPE (SPECIAL_DTYPEX) then default_device = "00"b3;
	else default_device = "01"b3;

	call ipc_$drain_chn (ev_chan, code);		/* Don't leave stay events around */

	if substr (dev_name, 1, 3) = "dsk" then status_tablep = addr (disk_status_table_$disk_status_table_);
	else if substr (dev_name, 1, 3) = "tap" then status_tablep = addr (tape_status_table_$tape_status_table_);
	else if substr (dev_name, 1, 3) = "prt" then status_tablep = addr (prt_status_table_$prt_status_table_);
	else if substr (dev_name, 1, 3) = "rdr" then status_tablep = addr (crz_status_table_$crz_status_table_);
	else if substr (dev_name, 1, 3) = "pun" then status_tablep = addr (cpz_status_table_$cpz_status_table_);
	else if substr (dev_name, 1, 3) = "imp" then status_tablep = addr (imp_status_table_$imp_status_table_);
	else status_tablep = null;

/* Set up work space */

	call ioi_$workspace (devx, workp, work_size, code); /* Get work area */
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "Unable to allocate workspace of ^d words.", work_size);
	     go to quit;
	end;

/* Initialize status queue */

	call ioi_$set_status (devx, 32, 4, code);	/* Define status queue */
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "Unable to allocate status queue.");
	     go to quit;
	end;
	sqptr = addr (work_seg (33));			/* Status queue is here */
	status_queue.completion.st = "0"b;		/* Reset all status present bits */
	stat.completion.st = "0"b;
	status_index = 1;				/* This is the first entry to use */

	time_limit = max_time;			/* Set time limit to max */
	call ioi_$timeout (devx, time_limit, code);	/* Set time limit */
	if code ^= 0 then
	     call com_err_ (code, cmd_name, "Unable to set time limit to ^d seconds.",
	     divide (time_limit, 1000000, 17, 0));

/* Enable program interrupt as a way to escape from being blocked when no event is coming */

ready:	on program_interrupt begin;			/* By getting a command when it happens */
	     if debug_sw then go to next;
	     flush_sw = "1"b;
	     go to get_stat;			/* Flush out last status */
	end;

/* Read next command line */

next:	if prompt_msg ^= "" then call ioa_$nnl ("^a", prompt_msg);
	call iox_$get_line (iox_$user_input, addr (input_line), length (input_line), input_len, code);
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "Reading for user_input");
	     go to next;
	end;
	if input_len > 0 then if substr (input_line, input_len, 1) = new_line then /* If line ends in a nl */
		input_len = input_len - 1;		/* Then truncate it */
	input_pos = 1;				/* Current position */

/* Analyze first word for command type */

	call next_word;				/* First get the next word */
	if end_line then go to next;			/* Some sort of null line  */
	dcw_word = "0"b;				/* Start with empty dcw */
	pcw_sw = "0"b;				/* Not now building a pcw */
	exec_spec_sw, exec_rept_sw, exec_no_err_sw = "0"b; /* Not in any special mode now */
	flush_sw = "0"b;

	if word = "tdcw" then go to b_tdcw;
	if word = "iotp" then go to b_iotp;
	if word = "iontp" then go to b_iontp;
	if word = "iotd" then go to b_iotd;
	if word = "idcw" then go to b_idcw;
	if word = "nidcw" then go to b_nidcw;
	if word = "pcw" then go to b_pcw;
	if word = "odcw" then go to b_oct;
	if word = "opcw" then go to b_opcw;
	if word = "print" | word = "p" then go to print;
	if word = "edit" | word = "e" then go to edit;
	if word = "name" then go to set_name;
	if word = "insert" | word = "i" then go to insert;
	if word = "update" | word = "u" then go to update;
	if word = "quit" | word = "q" then go to quit;
	if word = "delete" | word = "dl" | word = "d" then go to delete;
	if word = "execute" | word = "x" then go to execute;
	if word = "xs" then go to exec_spec;
	if word = "xr" then go to exec_rept;
	if word = "xre" then go to exec_rept_no_err;
	if word = "getstat" | word = "g" then go to get_stat;
	if word = "block" | word = "b" then go to block;
	if word = "dump" then go to dump;
	if word = "dumpb" then go to dumpb;
	if word = "patch" then go to patch;
	if word = "survey" then go to dump_survey;
	if word = "dtstat" then go to dump_dtstat;
	if word = "time" then go to set_time;
	if word = "work" then go to set_work;
	if word = "chan" then go to set_chan;
	if word = "susp" then go to susp_dev;
	if word = "rel" then go to rel_dev;
	if word = "prompt" then go to set_prompt;
	if word = "pattern" then go to set_pattern;
	if word = "save" then go to save_segment;
	if word = "restore" then go to restore_segment;
	if word = "reprint_status" | word = "rs" then go to reprint_status;
	if word = "status" | word = "st" then go to status_command;
	if word = "get_special" | word = "get_special_status" then go to get_special_status;
	if word = "get_detail" | word = "get_detailed_status" then go to get_detailed_status;

/* More possible requests */

	if word = "." then do;			/* If requested to identify my self */
	     call ioa_ ("^a", cmd_name);		/* Its me!!! */
	     go to next;
	end;
	if word = "?" then do;			/* If request for current status */
	     if insert_mode then out_temp = "insert"; else out_temp = "update";
	     call ioa_ ("Current list: ^d^[ (^a)^;^s^], dcw: ^d, mode: ^a", list, (list_name (list) ^= ""),
		list_name (list), idx-1, out_temp);
	     go to next;
	end;

std_err:	call ioa_ ("invalid word: ^a", word);
	go to next;

quit:	call clean_up;
	return;

/* Come here after dcw is built to update the correct dcw list */

store:	if pcw_sw then pcw_list (list) = dcw_word;	/* Pcw goes here */

	else do;
	     if insert_mode then do;			/* If in insert mode, list must be moved */
		i = dcw_len (list);			/* End of current list */
		do while (i >= idx);
		     j = i+1;			/* Destination word */
		     if j <= 32 then dcw_list (list, j) = dcw_list (list, i); /* Move it, but don't go off end */
		     i = i-1;
		end;
		dcw_len (list) = min (32, dcw_len (list)+1); /* Calc new length */
	     end;
	     dcw_list (list, idx) = dcw_word;		/* Copy in new word */
	     dcw_len (list) = max (dcw_len (list), idx);	/* Adjust count */
	     idx = min (32, idx+1);
	end;
	go to next;

/* Routine to build a TDCW */

b_tdcw:	tdcw.type = "10"b;				/* This makes it a TDCW */
	call next_word;				/* Get the next word */
	if end_line then go to store;			/* If all done */
	if octal_word then do;			/* If octal, then this is the address */
	     tdcw.address = bit (binary (octal_val, 18, 0)); /* So store it */
	     go to b_tdcw2;
	end;
b_tdcw1:	if word = "ec" then tdcw.ec = "1"b;		/* If ec bit needed */
	else if word = "res" then tdcw.res = "1"b;	/* If res bit wanted */
	else if word = "rel" then tdcw.rel = "1"b;	/* If rel bit wanted */
	else go to std_err;				/* Don't recognize it */
b_tdcw2:	call next_word;				/* Get next word */
	if end_line then go to store;
	else go to b_tdcw1;

/* Routine to build an IDCW */

b_idcw:	idcw.code = "111"b;				/* This makes it an IDCW */
	idcw.device = default_device;
	call next_word;
	if end_line then go to store;
	if octal_word then do;			/* Must be inst code */
	     idcw.command = bit (binary (octal_val, 6, 0)); /* So store it */
	     go to b_idcw2;
	end;

b_idcw1:	if word = "da" then idcw.device = bit6 ();	/* Device addrss follows */
	else if word = "ae" then idcw.ext = bit6 ();	/* Address extension follows */
	else if word = "ci" then idcw.chan_cmd = bit6 (); /* Channel instruction follows */
	else if word = "t" then idcw.count = bit6 ();	/* Tally follows */
	else if word = "ec" then idcw.ext_ctl = "1"b;
	else if word = "cont" then substr (idcw.control, 1, 1) = "1"b;
	else if word = "mark" then substr (idcw.control, 2, 1) = "1"b;
	else if word = "mask" then pcw.mask = "1"b;
	else if word = "reset" & pcw_sw then do;
	     pcw.mask = "1"b;
	     pcw.control = "11"b;
	end;
	else go to std_err;				/* No more things to test */

b_idcw2:	call next_word;				/* On to next one */
	if ^end_line then go to b_idcw1;
	else go to store;

/* Simple command for setting up a non-data transfer IDCW */

b_nidcw:	idcw.count = "000001"b;			/* Set tally = 1 */
	idcw.chan_cmd = "000010"b;			/* Non-data transfer code */
	go to b_idcw;				/* Otherwise, just like a regular IDCW */

/* Build a PCW, which is a lot like a IDCW */

b_pcw:	pcw_sw = "1"b;
	go to b_idcw;				/* Use the IDCW routine */

/* Build IOTP, IOTD, or IONTP dcw */

b_iotd:	dcw.type = "00"b;				/* Start here for IOTD */
	go to b_iodcw;

b_iotp:	dcw.type = "01"b;				/* Start here for IOTP */
	go to b_iodcw;

b_iontp:	dcw.type = "11"b;				/* Start here for IONTP */

b_iodcw:	call next_word;				/* This should be address */
	if end_line then go to store;
	if ^octal_word then go to std_err;
	dcw.address = bit (binary (octal_val, 18, 0));

	call next_word;				/* This should be tally */
	if end_line then go to store;
	if ^octal_word then go to std_err;
	dcw.tally = bit (binary (octal_val, 12, 0));

	call next_word;				/* This should be char pos */
	if end_line then go to store;
	if ^octal_word then go to std_err;
	dcw.char_pos = bit (binary (octal_val, 3, 0));

	go to store;				/* Done */

/* Store a dcw entered in octal */

b_oct:	call next_word;
	if end_line then go to store;			/* Just store zero */
	if ^octal_word then go to std_err;		/* Must be in octal */
	dcw_word = unspec (octal_val);
	go to store;

/* Build a pcw entered in octal */

b_opcw:	pcw_sw = "1"b;				/* Remember that this is pcw */
	go to b_oct;				/* And use octal routine */

/* Edit command which changes the dcw list being edited */

edit:	call next_word;				/* See if arg given */
	if ^end_line then do;
	     if word = "*" then do;			/* Any empty list */
		do i = 1 to 32;			/* Check all lists */
		     if empty_list (i) & list_name (i) = "" then do;
			call ioa_ ("Using list #^d.", i);
			list = i;
			go to edit1;
		     end;
		end;
		call ioa_ ("No empty lists.");
		go to next;
	     end;
	     else call check_list_num;		/* See if valid number or name */
	     list = dec_val;
edit1:	     call next_word;			/* See if name given */
	     if end_line then new_name = "";
	     else new_name = word;
	end;
	idx = 1;
	insert_mode = "0"b;
	if new_name ^= "" then go to set_name2;
	else go to next;

/* Update command, which turns off insert mode, and may change the current position */

update:	call get_dcw_num;
	insert_mode = "0"b;
	go to next;

/* Insert command, which turns on insert mode, and may change the current position */

insert:	call get_dcw_num;
	insert_mode = "1"b;
	go to next;

/* Routine to delete a word from a dcw list */

delete:	call get_dcw_num;
	i = idx;					/* Target word */
delete1:	j = i+1;					/* Source word to move from */
	if j > dcw_len (list) then do;		/* If reached end */
	     dcw_len (list) = max (dcw_len (list)-1, 0);	/* Adjust length */
	     go to next;
	end;
	dcw_list (list, i) = dcw_list (list, j);	/* Move word */
	i = i+1;					/* Next target word */
	go to delete1;

/* Routine to give a dcw list a name */

set_name:	call next_word;
	if end_line then new_name = "";
	else new_name = word;
set_name2:
	if new_name ^= "" then do i = 1 to 32;		/* Be sure name is not used elsewhere */
	     if list_name (i) = new_name then list_name (i) = "";
	end;
	list_name (list) = new_name;
	go to next;

/* Routine to set the time limit for connects */

set_time:	call debug_check;
	call next_word;				/* Get the next word */
	if end_line then do;			/* If nothing, then just print current time limit */
	     call ioa_ ("Time limit is ^d seconds", divide (time_limit, 1000000, 17, 0));
	     call ioa_ ("Max time limit is ^d seconds", divide (max_time, 1000000, 17, 0));
	     go to next;
	end;
	if ^dec_word then go to std_err;		/* Should be limit in seconds */
	time_limit = 1000000*dec_val;			/* Convert to micro seconds */
	call ioi_$timeout (devx, time_limit, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	go to next;

/* Command to change the size of the work space */

set_work:	call debug_check;
	call next_word;				/* Get next word */
	if end_line then do;			/* If no param, just print current size */
	     call ioa_ ("Buffer size is ^d words", work_size);
	     call ioa_ ("Max buffer size is ^d words", max_work);
	     go to next;
	end;
	if ^dec_word then go to std_err;		/* If specified, must be decimal */
	new_work_size = max (512, dec_val);		/* Save new size */
	call ioi_$workspace (devx, workp, new_work_size, code); /* Change size */
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "Setting workspace to ^d words.");
	     go to next;
	end;
	work_size = new_work_size;
	go to next;

/* Command to change the prompt message */

set_prompt: call next_word;
	if end_line then prompt_msg = "";		/* If null, set to no prompt */
	else prompt_msg = before (word, " ");		/* Otherwise get rest of word */
	go to next;

/* Command to set a channel required for I/O */

set_chan:	call debug_check;
	call next_word;
	if end_line then do;			/* No arguments means reset this feature */
	     call ioi_$set_channel_required (devx, 0, 0, code);
	     if code ^= 0 then call com_err_ (code, cmd_name);
	     go to next;
	end;

	call parse_io_channel_name_ (word, iom, chan, code);
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "^a", word);
	     go to next;
	end;

	call ioi_$set_channel_required (devx, iom, chan, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	go to next;

/* Suspend io on all devices on the mpc */

susp_dev:	call debug_check;
	call ioi_$suspend_devices (devx, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	go to next;

/* Release io on all devices on the mpc */

rel_dev:	call debug_check;
	call ioi_$release_devices (devx, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	go to next;

/* Commands for special and detailed status */

get_special_status:
	call debug_check;
	call ioi_$get_special_status (devx, stat_found, spec_status, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	else if ^stat_found then call ioa_ ("No special status stored.");
	else call ioa_ ("special status: ^w", spec_status);
	go to next;

get_detailed_status:
	call debug_check;
	call ioi_$get_detailed_status (devx, stat_found, detailed_status, code);
	if code ^= 0 then call com_err_ (code, cmd_name);
	else if ^stat_found then call ioa_ ("No detailed status from previous I/O.");
	else do;
	     do i = 27 to 2 by -1 while (detailed_status_array (i) = "0"b);
	     end;
	     call ioa_ ("Detailed status : ^v(^.4b ^)", i, detailed_status_array);
	end;
	go to next;

/* Routine to execute the dcw list */

execute:	exec_spec_sw = "0"b;			/* This is normal start */
	exec_rept_sw = "0"b;			/* Set  to execute once */
	exec_no_err_sw = "0"b;			/* Do not ignore errors */
	go to ex_join;

exec_spec: exec_spec_sw = "1"b;			/* Enter here if special interrupt required */
	exec_rept_sw = "0"b;
	exec_no_err_sw = "0"b;
	go to ex_join;

exec_rept_no_err:
	exec_no_err_sw = "1"b;			/* Going to ignore errors. */
	go to repeat;

exec_rept: exec_no_err_sw = "0"b;
repeat:	exec_spec_sw = "0"b;			/* No special wait */
	exec_rept_sw = "1"b;			/* But doing repeats */
ex_join:	exec_rept_cnt = 0;

	call debug_check;
	call get_list_num;
	if dec_val > 0 then do;			/* New list number */
	     list = dec_val;
	     idx = 1;
	     insert_mode = "0"b;
	end;

	if dcw_len (list) = 0 then do;		/* If list is empty */
	     call ioa_ ("List ^d^[ (^a)^] is empty.", list, list_name (list) ^= "", list_name (list));
	     go to next;
	end;

	do i = 1 to hbound (dcw_list, 2);		/* Copy list to work space */
	     if i <= dcw_len (list) then work_seg (i) = dcw_list (list, i);
	     else work_seg (i) = "0"b;
	end;

xagain:	if pcw_list (list) then call ioi_$connect_pcw (devx, 0, pcw_list (list), code); /* If i have a pcw */
	else call ioi_$connect (devx, 0, code);
	if code ^= 0 then do;
	     call com_err_ (code, cmd_name, "Issuing connect");
	     go to next;
	end;

block:	call debug_check;
	call ipc_$block (addr (event_list), addr (event_info), code); /* Wait for interrupt */
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, cmd_name, "While blocking for interrupt.");
	     go to next;
	end;

/* Analyze status */

gstat:	imp = addr (event_info.message);		/* Get pointer to ioi message */

	if imess.level = "111"b then do;		/* If special status */
	     if flush_sw then go to get_stat;
	     unspec (stat) = "0"b;			/* Cons up a status queue entry */
	     stat.level = 7;
	     stat.iom_stat = imess.status;
	     stat.completion.st = "1"b;
	     call print_status;
	     go to next;
	end;

	isp = addr (status_queue (status_index));	/* Current status entry */
	if ^istat.completion.st then do;
	     if flush_sw then go to get_stat;
	     call print_status;
	     go to next;
	end;

	stat = istat;				/* Copy status to my automatic area */
	istat.completion.st = "0"b;			/* Status no longer present in buffer */
	status_index = status_index+1;		/* Index for next status */
	if status_index > 4 then status_index = 1;
	if flush_sw then go to get_stat;

	if stat.completion.time_out then do;		/* If event due to time out */
	     call print_status;
	     go to next;
	end;

	statp = addr (stat.iom_stat);			/* Get pointer to iom stat area */

	if exec_rept_sw then do;			/* If doing repeatedly */
	     if exec_no_err_sw then go to xagain;	/* Forget about errors. */
	     if stat.level ^= 3 then go to pr_stat;	/* If not terminate */
	     if stat.completion.er then go to pr_stat;	/* If status indicates any error */
	     exec_rept_cnt = exec_rept_cnt + 1;
	     go to xagain;				/* Otherwise do it again */
	end;

pr_stat:	call print_status;

	if stat.completion.run then go to block;	/* If still running, wait for more status */
	if exec_spec_sw then go to block;		/* If a special needed.. */
	if exec_rept_sw then call ioa_ ("^d operations suceeded.", exec_rept_cnt);
	go to next;

/* Routine to force ioi get status call to check for any status */

get_stat:	call debug_check;
	call ipc_$read_ev_chn (ev_chan, i, addr (event_info), code); /* Check for event */
	if code ^= 0 then do;
	     call convert_ipc_code_ (code);
	     call com_err_ (code, cmd_name, "Reading event channel.");
	     go to next;
	end;
	if i ^= 0 then go to gstat;			/* Status has occured */
	if ^flush_sw then call ioa_ ("No events");	/* Nothing has happened */
	go to next;

/* Command to reprint the last_status */

reprint_status:
	save_status_mode = status_mode;		/* Reember current mode */
	call next_word;
	if end_line then status_mode = 3;		/* Default is edited */
	else call check_status_mode;
	call print_status;
	status_mode = save_status_mode;
	go to next;

/* Command to set the status mode */

status_command:
	call next_word;
	if end_line then call ioa_ ("Status mode is ^[brief^;long^;edited^]", status_mode);
	else call check_status_mode;
	go to next;

/* Procedure to print status */

print_status: proc;

dcl  bstat (8) bit (36) aligned based (addr (stat));

	     if ^stat.completion.st then do;
		call ioa_ ("No status available.");
		return;
	     end;

	     if status_mode = 2 then do;		/* Long mode */
		call ioa_ ("^(^w ^)", bstat);
		return;
	     end;

	     if stat.level = 1 | stat.level = 7 then do;
		call ioa_ ("^d ^.3b", stat.level, substr (stat.iom_stat, 1, 36));
		return;
	     end;

	     if stat.completion.time_out then do;
		call ioa_ ("Channel timed out.");
		return;
	     end;

	     if status_mode = 3 then do;
		call analyze_device_stat_$rsnnl (output_line, status_tablep, stat.iom_stat, "0"b);
		call ioa_ ("^a", output_line);
		return;
	     end;

	     call ioa_ ("^d ^w ^w maj=^b sub=^b", stat.level,
		substr (stat.iom_stat, 1, 36), substr (stat.iom_stat, 37, 36),
		addr (stat.iom_stat) -> status.major,
		addr (stat.iom_stat) -> status.sub);
	     return;

	end print_status;

/* Procedure to check a word for a valid status mode */

check_status_mode: proc;

	     if word = "brief" | word = "bf" then status_mode = 1;
	     else if word = "long" | word = "lg" then status_mode = 2;
	     else if word = "edited" | word = "ed" then status_mode = 3;
	     else do;
		call ioa_ ("Invalid status mode: ^a", word);
		go to next;
	     end;
	     return;

	end check_status_mode;

/* Routine to print a dcw list */

print:	call next_word;
	if ^end_line then do;			/* There is an arg */
	     if word = "all" then do;
		something_printed = "0"b;
		do i = 1 to 32;
		     if ^empty_list (i) then do;	/* List in use */
			call ioa_ ("List #^d ^[(^a)^]", i, (list_name (i) ^= ""), list_name (i));
			call print_subr (i);
			something_printed = "1"b;
		     end;
		end;
		if ^something_printed then call ioa_ ("No dcw lists defined");
		go to next;
	     end;
	     else if word = "names" then do;		/* Request for list of names */
		something_printed = "0"b;
		do i = 1 to 32;
		     if (list_name (i) ^= "") | ^empty_list (i) then do;
			call ioa_ ("^2d ^[*noname*^s^;^a^] ^[(empty)^]", i, (list_name (i) = ""), list_name (i),
			     empty_list (i));
			something_printed = "1"b;
		     end;
		end;
		if ^something_printed then call ioa_ ("No dcw lists defined.");
		go to next;
	     end;
	     call check_list_num;			/* Check for valid arg */
	     list = dec_val;
	     idx = 1;
	     insert_mode = "0"b;
	end;

	if empty_list (list) then call ioa_ ("List #^d ^[(^a) ^]empty.", list, list_name (list) ^= "",
	     list_name (list));
	else call print_subr (list);
	go to next;

/* Subroutine to print 1 dcw list */

print_subr: proc (listnum);

dcl  listnum fixed bin;
dcl  i fixed bin;

	     do i = 0 to dcw_len (listnum);		/* Loop thru current list */
		output_line = "";			/* Start with null line */

		if i = 0 then do;			/* Special case to print the pcw */
		     if pcw_list (listnum) then do;	/* If there is one */
			dcw_word = pcw_list (listnum); /* Get it */
			output_line = "pcw   ";
			go to print_pcw;
		     end;
		end;

		else do;
		     dcw_word = dcw_list (listnum, i);	/* Copy the current word */

		     if idcw.code = "111"b then do;	/* If an IDCW */
			output_line = "idcw  ";
print_pcw:		call oct (2, binary (idcw.command)); /* Get device instruction */
			if idcw.device then do;	/* If an address is present */
			     output_line = output_line || " da=";
			     call oct (2, binary (idcw.device));
			end;
			if idcw.ext then do;	/* If address extension present */
			     output_line = output_line || " ae=";
			     call oct (2, binary (idcw.device));
			end;
			if idcw.chan_cmd then do;	/* If channel instruction present */
			     output_line = output_line || " ci=";
			     call oct (2, binary (idcw.chan_cmd));
			end;
			if idcw.count then do;	/* If a tally is present */
			     output_line = output_line || " t=";
			     call oct (2, binary (idcw.count));
			end;
			if idcw.ext_ctl then if i = 0 then output_line = output_line || " mask";
			     else output_line = output_line || " ec";
			if substr (idcw.control, 1, 1) then output_line = output_line || " cont";
			if substr (idcw.control, 2, 1) then output_line = output_line || " mark";
		     end;

		     else if tdcw.type = "10"b then do; /* If a TDCW */
			output_line = "tdcw  ";
			call oct (6, binary (tdcw.address)); /* Convert address */
			if tdcw.ec then output_line = output_line || " ec";
			if tdcw.res then output_line = output_line || " res";
			if tdcw.rel then output_line = output_line || " rel";
		     end;

		     else do;			/* Some type of IODCW */
			if dcw.type = "00"b then output_line = "iotd  "; /* Get type first */
			else if dcw.type = "01"b then output_line = "iotp  ";
			else output_line = "iontp ";	/* Only one left */
			call oct (6, binary (dcw.address)); /* Data address first */
			output_line = output_line || " ";
			call oct (4, binary (dcw.tally));
			if dcw.char_pos then do;	/* If character pos present */
			     output_line = output_line || " cp=";
			     call oct (1, binary (dcw.char_pos));
			end;
		     end;

		     call ioa_$rsnnl ("^w", word, (0), dcw_word); /* Unpack the word */
		     if i = 0 then call ioa_ ("    ^a ^a  ^a", substr (word, 1, 6), substr (word, 7, 12),
			output_line);
		     else call ioa_ ("^2o^[*^; ^] ^a ^a  ^a", i-1, (i = idx & list = listnum), substr (word, 1, 6),
			substr (word, 7, 6), output_line);
		end;
	     end;

	     return;

	end print_subr;

/* Command to dump contents of ioi work space segment */

dumpb:	dp_byte = "1"b;				/* Dump is in bytes */
	go to dp_join;

dump:	dp_byte = "0"b;				/* Dump is in words */
dp_join:	dp_loc = 65;				/* Default location */
	dp_len = 8;				/* Default word count */

	call next_word;
	if end_line then go to dump_go;		/* Use defaults */
	if ^octal_word then go to std_err;
	dp_loc = octal_val + 1;
	call next_word;
	if end_line then go to dump_go;
	if ^octal_word then go to std_err;
	dp_len = octal_val;				/* This is word count */

dump_go:	i = 0;					/* This will count words on current print line */
	output_line = "";

	if ^dp_byte then do dp_loc = dp_loc to (dp_loc+dp_len-1); /* If dump is in words */

dp_nl:	     if i = 0 then do;			/* If line is empty */
		call ioa_$rsnnl ("^4o", word, (0), dp_loc-1); /* Edit address */
		output_line = substr (word, 1, 4) || " ";
	     end;
	     i = i + 1;				/* Count another word on the line */
	     if i > 8 then do;			/* If no room for another line */
		call ioa_ ("^a", output_line);	/* Dump current */
		i = 0;
		go to dp_nl;			/* And start another */
	     end;
	     call ioa_$rsnnl ("^w", word, (0), work_seg (dp_loc)); /* Edit a word */
	     output_line = output_line || " " || substr (word, 1, 12);
	end;

	else do;					/* Dump is in binary bytes */
	     byte_ptr = addr (work_seg (dp_loc));	/* Get array pointer */
	     nbytes = dp_len;			/* Number of bytes to dump */
	     do j = 1 to nbytes;
		i = i + 1;			/* Count entry on line */
		if i > 10 then do;			/* If line full */
		     call ioa_ ("^a", output_line);
		     i = 1;
		     output_line = "";
		end;
		call ioa_$rsnnl ("^b", word, (0), bbyte (j)); /* Format new word */
		output_line = output_line || " " || substr (word, 1, 8);
	     end;
	end;

	call ioa_ ("^a", output_line);		/* Dump last line */
	go to next;

/* Command to patch data into ioi buffer */

patch:	call next_word;				/* Get address */
	if end_line then do;
	     call ioa_ ("Address missing");
	     go to next;
	end;
	if ^octal_word then go to std_err;
	dp_loc = octal_val + 1;			/* First word to patch */

	call next_word;				/* First data word */
	if end_line then do;
	     call ioa_ ("Data missing");
	     go to next;
	end;

	do while (^end_line);			/* Do for rest of input line */
	     if ^octal_word then go to std_err;		/* Only octal allowed */
	     work_seg (dp_loc) = unspec (octal_val);	/* Store whole word */
	     dp_loc = dp_loc + 1;			/* Step to next word */
	     call next_word;			/* Fetch next arg */
	end;
	go to next;

/* Command to repeat a data pattern in the buffer */

set_pattern:
	call next_word;				/* Address */
	if end_line then do;
	     call ioa_ ("Address missing");
	     go to next;
	end;
	if ^octal_word then go to std_err;
	dp_loc = octal_val + 1;			/* Start address */

	call next_word;				/* Count */
	if end_line then do;
	     call ioa_ ("Count missing");
	     go to next;
	end;
	if ^octal_word then go to std_err;
	dp_rpt = octal_val;

	dp_len = 0;
	call next_word;
	do while (^end_line);			/* Scan rest of command */
	     if ^octal_word then go to std_err;
	     work_seg (dp_loc) = unspec (octal_val);
	     dp_len = dp_len + 1;
	     dp_loc = dp_loc + 1;
	     call next_word;
	end;

	if dp_len = 0 then do;
	     call ioa_ ("No data");
	     go to next;
	end;

	do dp_rpt = dp_rpt-1 by -1 while (dp_rpt > 0);
	     do i = 1 to dp_len;
		work_seg (dp_loc) = work_seg (dp_loc - dp_len);
		dp_loc = dp_loc + 1;
	     end;
	end;
	go to next;

/* Dump data returned by survey devices is readable format */

dump_survey: dp_loc = 65;				/* Default location of data */
	call next_word;				/* See if location given */
	if ^end_line then do;			/* If it was */
	     if ^octal_word then go to std_err;
	     else dp_loc = octal_val + 1;		/* Use this loc */
	end;

	survey_ptr = addr (work_seg (dp_loc));		/* This locates the data */

	do i = 1 to 16 while (string (survey_table (i))); /* Do until all devices done */
	     call ioa_$rsnnl ("handler ^d:", out_temp, (0), binary (hand_addr (i)));
	     output_line = out_temp;			/* This starts the line */
	     if hand_resv (i) then output_line = output_line || " reserved";
	     if hand_op (i) then output_line = output_line || " operational";
	     if hand_ready (i) then output_line = output_line || " ready";
	     if hand_track (i) then output_line = output_line || " 9 track";
	     else output_line = output_line || " 7 track";
	     if hand_speed (i) = "001"b then output_line = output_line || " 75 ips";
	     else if hand_speed (i) = "010"b then output_line = output_line || " 125 ips";
	     else if hand_speed (i) = "100"b then output_line = output_line || " 200 ips";
	     else do;				/* Some unusual speed code */
		call ioa_$rsnnl (" speed code=^b", out_temp, (0), hand_speed (i));
		output_line = output_line || out_temp;
	     end;
	     if hand_record (i) = "0000"b then output_line = output_line || " 1600 bpi";
	     else if hand_record (i) = "0001"b then output_line = output_line || " 200,556,800 bpi";
	     else if hand_record (i) = "0100"b then output_line = output_line || " 200,556,800,1600 bpi";
	     else do;				/* Some other strange code */
		call ioa_$rsnnl (" density code=^b", out_temp, (0), hand_record (i));
		output_line = output_line || out_temp;
	     end;

	     call ioa_ ("^a", output_line);
	end;

	go to next;

/* Command to display detailed tape status */

dump_dtstat: dp_loc = 65;				/* Default location */
	call next_word;
	if ^end_line then do;
	     if ^octal_word then go to std_err;
	     dp_loc = octal_val + 1;
	end;

	dtstp = addr (work_seg (dp_loc));		/* Get pointer to detailed status */

	output_line = "Byte 0:";
	if dt_stat.devflt then output_line = output_line || "  device-fault";
	if dt_stat.ccerr then output_line = output_line || "  command-code-error";
	if dt_stat.rawerr then output_line = output_line || "  read-after-write-error";
	if dt_stat.mbot then output_line = output_line || "  multiple BOTs";
	if dt_stat.bot then output_line = output_line || "  BOT";
	if dt_stat.eot then output_line = output_line || "  EOT";
	if dt_stat.standby then output_line = output_line || "  standby";
	if dt_stat.marg then output_line = output_line || "  marginal-condition";
	call ioa_ ("^a", output_line);

	output_line = "Byte 1:";
	if dt_stat.loaded then output_line = output_line || "  loaded";
	if dt_stat.lcw then output_line = output_line || "  last-command-write";
	if dt_stat.lcf then output_line = output_line || "  last-command-forward";
	if dt_stat.rewind then output_line = output_line || "  rewinding";
	if dt_stat.wpr then output_line = output_line || "  write-permit-ring";
	if dt_stat.spr then output_line = output_line || "  software-write-permit";
	if dt_stat.diag then output_line = output_line || "  diagnostic-mode";
	if dt_stat.ccpe then output_line = output_line || "  command-code-parity-even";
	call ioa_ ("^a", output_line);

	output_line = "Byte 2:";
	output_line = output_line || "  density=";
	if dt_stat.denr = "000"b then output_line = output_line || "1600";
	else if dt_stat.denr = "001"b then output_line = output_line || "3200";
	else if dt_stat.denr = "100"b then output_line = output_line || "800";
	else if dt_stat.denr = "101"b then output_line = output_line || "1200";
	else if dt_stat.denr = "110"b then output_line = output_line || "200";
	else if dt_stat.denr = "111"b then output_line = output_line || "556";
	else do;
	     call ioa_$rsnnl ("(^b)", out_temp, (0), dt_stat.denr);
	     output_line = output_line || out_temp;
	end;
	if dt_stat.lowt then output_line = output_line || "  low-threshold";
	output_line = output_line || "  recording=";
	if dt_stat.denc = "0000"b then output_line = output_line || "1600";
	else if dt_stat.denc = "0001"b then output_line = output_line || "1600,800,556,200";
	else if dt_stat.denc = "0010"b then output_line = output_line || "1200,800,556,200";
	else if dt_stat.denc = "0011"b then output_line = output_line || "1200";
	else if dt_stat.denc = "0100"b then output_line = output_line || "800,556,200";
	else if dt_stat.denc = "0101"b then output_line = output_line || "556,200";
	else if dt_stat.denc = "0110"b then output_line = output_line || "200";
	else if dt_stat.denc = "0111"b then output_line = output_line || "3200";
	else do;
	     call ioa_$rsnnl ("(^b)", out_temp, (0), dt_stat.denc);
	     output_line = output_line || out_temp;
	end;
	call ioa_ ("^a", output_line);

	output_line = "Byte 3:";
	i = bin (dt_stat.speed);
	output_line = output_line || "  speed=";
	if i <= 15 then output_line = output_line || speed_constant (i);
	else do;
	     call ioa_$rsnnl ("(^b)", out_temp, (0), dt_stat.speed);
	     output_line = output_line || out_temp;
	end;
	if dt_stat.track then output_line = output_line || "  9-channel";
	else output_line = output_line || "  7-channel";
	if dt_stat.nsbot then output_line = output_line || "  non-stanard-BOT";
	call ioa_ ("^a", output_line);

	output_line = "Byte 4:";
	if dt_stat.dms then output_line = output_line || "  device-multiple-select";
	output_line = output_line || "  address=";
	call ioa_$rsnnl ("^d", out_temp, (0), bin (dt_stat.addr));
	output_line = output_line || out_temp;
	call ioa_ ("^a", output_line);

	go to next;

/* Save dcw lists in a segment */

save_segment:
	call save_seg_util ("1"b);			/* Find and/or make segment */

	save_seg.version = 1;
	save_seg.code = save_seg_code;
	save_seg.time = clock ();
	save_seg.pcw_list = pcw_list;
	save_seg.dcw_len = dcw_len;
	save_seg.list_name = list_name;
	save_seg.dcw_list = dcw_list;
	call adjust_bit_count_ (dir, ename, "0"b, (0), code);
	if code ^= 0 then call com_err_ (code, cmd_name, "Setting bit_count");
	call hcs_$terminate_noname (save_segp, code);
	save_segp = null;
	go to next;

/* Restore dcw lists from a segment */

restore_segment:
	call save_seg_util ("0"b);			/* Find segment */

	if (save_seg.code ^= save_seg_code) | (save_seg.version ^= 1) then do;
	     call ioa_ ("not a test_dcw data segment");
	     call hcs_$terminate_noname (save_segp, code);
	     save_segp = null;
	     go to next;
	end;

	call date_time_ (save_seg.time, time_string);
	call ioa_ ("Segment saved at ^a", time_string);
	pcw_list = save_seg.pcw_list;
	dcw_len = save_seg.dcw_len;
	list_name = save_seg.list_name;
	dcw_list = save_seg.dcw_list;
	call hcs_$terminate_noname (save_segp, code);
	save_segp = null;
	insert_mode = "0"b;
	idx, list = 1;
	if ^debug_sw then do i = 1 to 32;		/* Loop thru and fix device addresses */
	     if pcw_list (i) ^= "0"b then addr (pcw_list (i)) -> pcw.device = default_device;
	     do j = 1 to dcw_len (i);
		if addr (dcw_list (i, j)) -> idcw.code = "111"b then
		     addr (dcw_list (i, j)) -> idcw.device = default_device;
	     end;
	end;
	go to next;


/* Procedure for initiating or making the save segment */

save_seg_util: proc (make_sw);

dcl  make_sw bit (1);				/* Says whether to call make_seg or initiate */

	     call next_word;
	     if end_line then do;
		call ioa_ ("Path missing");
		go to next;
	     end;
	     call expand_pathname_ (word, dir, unsuffixed_ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, cmd_name, "^a", word);
		go to next;
	     end;
	     call suffixed_name_$make (unsuffixed_ename, cmd_name, ename, code);
	     if code ^= 0 then do;
		call com_err_ (code, cmd_name, "^a", unsuffixed_ename);
		go to next;
	     end;
	     if make_sw then call hcs_$make_seg (dir, ename, "", 01010b, save_segp, code);
	     else call hcs_$initiate (dir, ename, "", 0, 0, save_segp, code);
	     if save_segp = null then do;
		call com_err_ (code, cmd_name, "^a^[>^]^a", dir, dir ^= ">", ename);
		go to next;
	     end;

	     return;

	end save_seg_util;

/* Internal procedure to extract the next word from the input line */

next_word: proc;

	     end_line = "0"b;			/* Reset the end of line flag */
nw_loop:	     if input_pos > input_len then do;		/* Past end of line */
		end_line = "1"b;			/* Set end of line flag */
		return;				/* And exit */
	     end;
	     temp_char = substr (input_line, input_pos, 1); /* Get next char */
	     if temp_char = " " | temp_char = tab then do; /* If white space */
		input_pos = input_pos + 1;		/* Ignore it */
		go to nw_loop;
	     end;

	     i = input_pos;				/* Current position */
nw_scan:	     i = i + 1;				/* Next position */
	     if i > input_len then go to nw_found;	/* Word is ended by the end of the line */
	     temp_char = substr (input_line, i, 1);	/* Get next char */
	     if ^(temp_char = " " | temp_char = tab) then go to nw_scan; /* If a meaningful character */
nw_found:	     word = substr (input_line, input_pos, i-input_pos); /* Extract the word */
	     input_pos = i;				/* Update position */

	     octal_val = cv_oct_check_ (word, i);	/* Test it */
	     octal_word = (i = 0);			/* Set octal flag if no errors */
	     dec_val = cv_dec_check_ (word, i);		/* Attempt the conversion */
	     dec_word = (i = 0);			/* Set decimal flag if no errors */

	     return;

	end next_word;

/* Routines to convert numbers to octal char strings */

oct:	proc (l, val);

dcl  l fixed bin;					/* Length of string */
dcl  val fixed bin (35);				/* Value to convert */

	     call ioa_$rsnnl ("^w", word, (0), val);	/* Get octal version of word */
	     output_line = output_line || substr (word, 13-l, l);

	end oct;

/* Fuction which returns the next word on the input line as a bit string */

bit6:	proc returns (bit (6));

	     call next_word;			/* Get next word */
	     if end_line then go to store;
	     if ^octal_word then go to std_err;
	     return (bit (binary (octal_val, 6, 0)));

	end bit6;


/* Called by commands which are not allowed in debug mode */

debug_check: proc;

	     if ^debug_sw then return;

	     call ioa_ ("Command not allowed in debug mode");
	     go to next;

	end debug_check;

/* Routine to get next word as a list number */

get_list_num: proc;

	     dec_val = -1;
	     call next_word;
	     if end_line then return;
check_list_num: entry;
	     if dec_word then do;
		if dec_val < 1 | dec_val > 32 then do;
		     call ioa_ ("Invalid dcw list number: ^d", dec_val);
		     go to next;
		end;
		else return;
	     end;
	     do i = 1 to 32;
		if list_name (i) = word then do;
		     dec_val = i;
		     return;
		end;
	     end;
	     call ioa_ ("No dcw list named ^a", word);
	     go to next;

	end get_list_num;

/* Function which tests for an empty DCW list */

empty_list: proc (l) returns (bit (1));

dcl  l fixed bin;

	     return ((pcw_list (l) = "0"b) & (dcw_len (l) = 0));

	end empty_list;

/* Routine to return the next word as a dcw number */

get_dcw_num: proc;

	     call next_word;
	     if end_line then return;			/* If no more, don't change num */
	     if ^octal_word then go to std_err;
	     if octal_val < 0 | octal_val > 31 then go to std_err;
	     idx = octal_val + 1;
	     return;

	end get_dcw_num;

/* Cleanup handler */

clean_up:	proc;

	     if rcp_id ^= "0"b then do;		/* If device attached thru rcp */
		call rcp_$detach (rcp_id, "0"b, 0, "", code);
		rcp_id = "0"b;
	     end;

	     if ev_chan ^= -1 then do;		/* If event channel created */
		call ipc_$delete_ev_chn (ev_chan, code);
		ev_chan = -1;
	     end;

	     if ptr_array (1) ^= null then do;
		call release_temp_segments_ (cmd_name, ptr_array, code);
		ptr_array = null;
	     end;

	     if save_segp ^= null then do;
		call hcs_$terminate_noname (save_segp, code);
		save_segp = null;
	     end;

	     return;

	end clean_up;

     end test_dcw;




		    test_tape.pl1                   03/25/86  1058.7rew 03/25/86  1055.7      452034



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


/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-18,Coppola):
     Support FIPS.
                                                   END HISTORY COMMENTS */
/* Modified 12/20/79 by R.L. Coppola and Paul Farley to add 6250 b.p.i. capability */
/* Modified June 1980 by R.L. Coppola to clean up several bugs and provide detailed status
   reporting and support of MTP610's */

/* Modified Nov 1981 by Rich Coppola to fix bug in compatibility option */

/* Modified Apr 14, 1982 by Rich Coppola to fix bug in test for recursive calls
   probably caused by previous modification. */
/* Modified 7/7/82 BIM to restore arg processing busted by above. */
/* Modified September 1982 by C. Hornig to fix config processing. */
/* Modified October 1982 By Rich Coppola for changes in call to
   analyze_detail_stat_.
   Also removed config processing as that is done in analyze_detail_stat_
   and not needed here.
*/
/* Modified July/Aug. 1983 by Paul Farley to correct the following:
   Usage message (phx14639, phx15524) removed, none required.
   Added the current time to error & info messages.
   Added code to display current parameters after arg parsing (or to show dflt).
   Removed "-retry" arg, made it the default, and removed all code
   that was used when in "no retry" mode. Also if doing IO retry, the data
   alert messages will be only recorded and not printed.
   Fixed bug with data buffer loading when using -compare.
   Also if first drive of -compare string cannot be attached
   then the test will now terminate.
   Added code in interp_xstats to summarize the status list.
   Changed the ext_buffr to be a temp_seg, so that more errors could
   be captured.
   Modified Nov. 1984 by Paul Farley to write two EOFs at the end of a write
   so that the read pass can use this to know when to stop reading.
   Modified July 1985 by Paul Farley for FIPS tape.
*/

/* format: style4,delnl,insnl,ifthenstmt,indnoniterend */
test_tape:
     procedure options (variable);


dcl  (vid, den8, den16, den6250) bit (1),
     program_interrupt condition,
     (write_error, read_error, irrec_write, irrec_read, rd_comp_err) fixed bin,
     cleanup condition,
     track7 bit (1) init ("0"b),
     retry_in_progress bit (1) init ("0"b),
     set_den_sw bit (1) init ("0"b),
     (comment_sw, sys_sw) bit (1) init ("0"b),
     ext_sw bit (1) init ("1"b),
     timer_manager_$sleep entry (fixed bin (71), bit (2)),
     (code, ecode) fixed bin (35) init (0),
     ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)),
     com_err_ entry options (variable),
     ipc_$block entry (ptr, ptr, fixed bin (35)),
     fail char (100) varying,
     mask bit (36),
     doing char (16) varying init ("mount"),
     dev_name char (32) init (""),
     comment char (55) init (""),
     reel_comment char (64),
     name char (32) init (""),
     (man_ptrn, rand_ptrn) bit (1) init ("0"b),
     (rec_wrt, rec_rd) fixed bin init (0),
     seed fixed bin (35) init (34546657),
     num_ret float bin (27),
     buf_init bit (1) init ("0"b),
     bufarray (1040) bit (36),
     buftemp bit (37440) based (addr (bufarray)),
     rek fixed bin (35) based (addr (bufarray)),
     read_buff bit (37440),
     err_buff (1040) bit (36) based (addr (read_buff)),
     ntimes fixed bin (25),
     det_valid bit (1) aligned,
     ioi_idx fixed bin,
     rsr_data bit (216) unal,
     (at_eot, detected_eof) bit (1) init ("0"b),
     (read_sw, write_sw, rew_sw, clean_up_sw) bit (1) init ("0"b),
     comp_sw bit (1) init ("0"b),
     dev_sw bit (1) init ("0"b),
     dev_array (16) char (32) init ((16) ("")),
     num_drives fixed bin int static init (0),
     comp_lp_ctr fixed bin int static init (0),
     (tdcm_attached, tape_mounted) bit (1) int static init ("0"b),
     nargs fixed bin,
     err_sum_sw bit (1) init ("0"b),
     (argptr, dstat_ptr) ptr,
     arglen fixed bin (21),
     arg_string char (arglen) based (argptr),
     blank_rd fixed bin init (0),
     yy fixed bin,
     temp fixed bin (35),				/* temp for compiler bug */
     (reelid, save_reel) char (9) init (""),
     wait_flag bit (1) init ("0"b),
     (wait, wait_cnt) fixed bin (35) init (0),
     density bit (36),
     att_bffr bit (208) init ("0"b),
     ext_bffr_ptr ptr init (null),
     1 ext_bffr (da_cnt) aligned based (ext_bffr_ptr),
       2 xrec_no fixed bin,
       2 xdoing fixed bin,
       2 iom_status bit (36) aligned,
       2 ext_data bit (208) unal,
     recursive_ fixed bin internal static,
     da_cnt fixed bin init (0),
     1 wait_list aligned,
       2 n fixed bin,
       2 chan (1) fixed bin (71),
     ndc_sw bit (1) init ("0"b),
     codex fixed bin init (0),
     dev_type fixed bin init (0),
     1 message aligned,
       2 chname fixed bin (71),
       2 message fixed bin (71),
       2 sender bit (36),
       2 origin,
         3 (devsignal, ring) bit (18) unaligned,
       2 channel_index fixed bin,
     stat_ptr ptr,
     1 stat_chk aligned based (stat_ptr),
       2 stat_pad1 bit (2) unaligned,
       2 stat_maj bit (4) unaligned,
       2 stat_min bit (6) unaligned,
       2 stat_pad2 bit (24) unaligned,
     i fixed bin (35) init (0),
     (k, l) fixed bin,
     (wrx, rdx) fixed bin init (0),
     (substr, index, addr, baseptr, bin, char, empty, fixed, rel, rtrim, unspec, null, length, string) builtin,
     ioa_ entry options (variable),
     get_temp_segment_ entry (char (*), ptr, fixed bin (35)),
     release_temp_segment_ entry (char (*), ptr, fixed bin (35)),
     error_table_$resource_attached ext fixed bin (35),
     error_table_$multiple_io_attachment fixed bin (35) ext static,
     error_table_$resource_assigned ext fixed bin (35),
     error_table_$resource_unavailable ext fixed bin (35),
     error_table_$inconsistent ext fixed bin (35),
     error_table_$bad_density external fixed bin (35),
     error_table_$noarg external fixed bin (35),
     error_table_$badopt external fixed bin (35),
     random_$uniform entry (fixed bin (35), float bin (27)),
     cu_$arg_count entry (fixed bin, fixed bin (35)),
     cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
     cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
     tdcm_$tdcm_attach entry (ptr, fixed bin (35)),
     tdcm_$tdcm_set_signal entry (ptr, fixed bin (35)),
     tdcm_$tdcm_reset_signal entry (ptr, fixed bin (35)),
     tdcm_$tdcm_message entry (ptr, char (*), fixed bin (1), fixed bin (35)),
     tdcm_$tdcm_iocall entry (ptr, fixed bin (35)),
     tdcm_$tdcm_detach entry (ptr, fixed bin (35));

dcl  rec_cap char (16) var,
     dev_spd char (8) var;


dcl  rec_tbl (0:11) char (16) var static options (constant)
	init ("1600", "200/556/800/1600", " ", " ", "200/556/800", "200/556", " ", " ", "800/1600", "556/800", "6250",
	"1600/6250");

dcl  spd_tbl (0:3) char (8) static options (constant) init (" 75 ips ", "        ", "125 ips ", "200 ips ");

dcl  dens_ (4) fixed bin static options (constant) init (6250, 1600, 0, 800);

dcl  ioi_$get_detailed_status entry (fixed bin, bit (1) aligned, bit (*), fixed bin (35));
dcl  analyze_detail_stat_ entry (char (*), bit (36) aligned, bit (*) unal, ptr, fixed bin (35));
dcl  analyze_detail_stat_$rsnnl entry (char (*), bit (36) aligned, bit (*) unal, char (*) var, bit (1), fixed bin (35));
dcl  analyze_device_stat_$rsnnl entry (char (*) var, ptr, bit (72) aligned, bit (18) aligned);
dcl  stat_tablep ptr;
dcl  tape_status_table_$tape_status_table_ ext;
%page;
/* Begin Here */

get_args:
	call cu_$arg_count (nargs, code);

	if code ^= 0 then do;
	     call com_err_ (code, "test_tape");
	     return;
	     end;

	if recursive_ = -1 then do;
	     code = error_table_$multiple_io_attachment;
	     call com_err_ (code, "test_tape", "test_tape has been recursively invoked.");
	     call com_err_ (0, "test_tape", "enter the release (rl) command and recall");
	     return;
	     end;

	stat_tablep = addr (tape_status_table_$tape_status_table_);

	read_sw = "1"b;
	string (comment) = "";
	string (reel_comment) = "";
	sys_sw = "0"b;
	ext_sw = "0"b;
	write_sw = "1"b;
	mask = (12)"010"b;
	ntimes = 100000;
	vid = "0"b;
	den8 = "0"b;
	den6250 = "0"b;
	den16 = "1"b;
	density = "000100000000000000000000000000000000"b;
	k = 0;
	write_error, read_error, irrec_write, irrec_read, rd_comp_err = 0;

arg_loop:
	do while (nargs - k > 0);

/* -------------------------------------------------------------------------------------------------- */
/*                                                                                                  */
/*     Set up the indicators to read only.                                                          */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */
	     k = k + 1;
	     call cu_$arg_ptr (k, argptr, arglen, code);

	     if arg_string = "-r" | arg_string = "-read" then do;
		read_sw = "1"b;
		write_sw = "0"b;
		go to next_arg;
		end;



/* -------------------------------------------------------------------------------------------------- */
/*                                                                                                  */
/*     Set up the indicators to write only.                                                         */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */
	     if arg_string = "-w" | arg_string = "-write" then do;
		read_sw = "0"b;
		write_sw = "1"b;
		go to next_arg;
		end;

/* --------------------------------------------------------------------------------------------------- */
/*                                                                                                   */
/*     Both read and write have been specifically requested even though these are the default        */
/*     no special processing is needed so proceed to the next argument                               */
/*                                                                                                   */
/* --------------------------------------------------------------------------------------------------- */


	     if arg_string = "-wr" | arg_string = "-write_read" then do;
		go to next_arg;
		end;


/* -------------------------------------------------------------------------------------------------- */
/*                                                                                                  */
/*     Pick up the pattern and check to be sure it is valid.                                        */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */
	     if arg_string = "-ptrn" | arg_string = "-pattern" then do;
		if rand_ptrn then do;
ptrn_err:
		     call com_err_ (0, "test_tape", "Incompatible options, -ptrn and -random.");
		     go to bad_arg;
		     end;
		k = k + 1;
		if k > nargs then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing data pattern.");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if index (arg_string, "-") ^= 0 then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing data pattern.");
		     go to bad_arg;
		     end;
		temp = cv_oct_check_ (arg_string, code);
		mask = unspec (temp);
		if code ^= 0 then do;
		     call com_err_ (code, "test_tape", "Character ^d of data pattern is invalid.");
		     go to bad_arg;
		     end;
		man_ptrn = "1"b;
		go to next_arg;
		end;

	     if arg_string = "-random" then do;
		if man_ptrn then goto ptrn_err;
		rand_ptrn = "1"b;
		goto next_arg;
		end;

/* --------------------------------------------------------------------------------------------------- */
/*                                                                                                   */
/*     Pick up the number of records to write and/or read and make sure it is a valid decimal number. */
/*                                                                                                   */
/* --------------------------------------------------------------------------------------------------- */

	     if arg_string = "-count" | arg_string = "-ct" then do;
		k = k + 1;
		if k > nargs then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing record count.");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if index (arg_string, "-") ^= 0 then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing record count.");
		     go to bad_arg;
		     end;
		ntimes = cv_dec_check_ (arg_string, code);
		if code ^= 0 then do;
		     call ioa_ ("Character ^d of the record count is invalid.", code);
		     go to bad_arg;
		     end;
		go to next_arg;
		end;

/* -------------------------------------------------------------------------------------------------- */
/*                                                                                                  */
/*     Get the user designated volume id.                                                           */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */
	     if arg_string = "-volume" | arg_string = "-vol" then do;
		k = k + 1;
		if k > nargs then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing volume id.");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if char (arg_string, 1) = "-" then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing volume id.");
		     go to bad_arg;
		     end;
		reelid = arg_string;
		save_reel = reelid;
		vid = "1"b;
		go to next_arg;

		end;


/* ***********************************************
   *   Pick up any comments to reel information	  *
   *********************************************** */

	     if arg_string = "-comment" | arg_string = "-com" then do;
		k = k + 1;
		if k > nargs then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing Comment.");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if index (arg_string, "-") ^= 0 then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing Comment.");
		     go to bad_arg;
		     end;

		if length (arg_string) > 55 then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Comment String > 55 chars.");
		     go to bad_arg;
		     end;

		comment = arg_string;
		comment_sw = "1"b;
		go to next_arg;
		end;

/* -------------------------------------------------------------------------------------------------- */

/*                                                                                                  */
/*     Pick up the specified density and set the indicator  accordingly.              */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */
	     if arg_string = "-density" | arg_string = "-den" then do;
		k = k + 1;
		if k > nargs then do;
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing density.");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if arg_string = "800" then do;
		     den8 = "1"b;
		     den16 = "0"b;
		     den6250 = "0"b;
		     density = "001000000000000000000000000000000000"b;
		     end;

		else if arg_string = "1600" then do;
		     den8 = "0"b;
		     den16 = "1"b;
		     den6250 = "0"b;
		     density = "000100000000000000000000000000000000"b;
		     end;

		else if arg_string = "6250" then do;
		     den6250 = "1"b;
		     den8 = "0"b;
		     den16 = "0"b;
		     density = "000010000000000000000000000000000000"b;
		     end;


		else do;
		     code = error_table_$bad_density;
		     call com_err_ (code, "test_tape", "Only 800, 1600 or 6250 bpi may be specified for test_tape.");
		     go to bad_arg;
		     end;
		go to next_arg;
		end;


/* --------------------------------------------------------------------------------- */
/*            pick up type handler (7 or 9 track).                                       */
/*                        set track7 flag if requested                                    */
/* --------------------------------------------------------------------------------- */

	     if arg_string = "-track7" | arg_string = "-tk7" then do;
		den8 = "1"b;
		den16 = "0"b;
		den6250 = "0"b;
		track7 = "1"b;
		density = "001000000000000000000000000000000000"b;
		go to next_arg;
		end;

/* ------------------------------------------------------------------- */
/*     See if user wants to turn on Detailed Status output      */

/* ------------------------------------------------------------------- */

	     if arg_string = "-raw" then do;
		ext_sw = "1"b;
		go to next_arg;
		end;

/* ------------------------------------------------------------------- */
/*                                                                    */
/*	           See if this is a no data compare read pass              */
/*                                                                   */
/* ----------------------------------------------------------------- */

	     if arg_string = "-ndc" | arg_string = "no_data_compare" then do;
		ndc_sw = "1"b;
		go to next_arg;
		end;

/* **************************************
   *    See if user wants wait option    *
   ************************************** */

	     if arg_string = "-wait" | arg_string = "-wt" then do;
		wait_flag = "1"b;
		k = k + 1;
		if k > nargs then do;
		     wait_cnt = 2;			/* default */
		     goto done_args;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if index (arg_string, "-") ^= 0 then do;
		     wait_cnt = 2;			/* default */
		     k = k - 1;
		     goto next_arg;
		     end;
		wait_cnt = cv_dec_check_ (arg_string, code);
		if code ^= 0 then do;
		     call com_err_ (code, "test_tape", arg_string);
		     go to bad_arg;
		     end;
		goto next_arg;
		end;

/* *******************************************
   *    See if user wants a certain drive     *
   ******************************************* */

	     if arg_string = "-dv" | arg_string = "-device" then do;
		if comp_sw then goto no_good;
		k = k + 1;
		if k > nargs then do;
dv_error:
		     code = error_table_$noarg;
		     call com_err_ (code, "test_tape", "Missing device name");
		     go to bad_arg;
		     end;
		call cu_$arg_ptr (k, argptr, arglen, code);
		if index (arg_string, "-") ^= 0 then goto dv_error;
		dev_name = arg_string;
		dev_sw = "1"b;
		goto next_arg;
no_good:
		code = error_table_$inconsistent;
		call com_err_ (code, "test_tape", "Can't have both -device and -compare options at the same time!");
		go to bad_arg;
		end;

/* **************************************************
   *    See if user wants the compatability option   *
   ************************************************** */

	     if arg_string = "-comp" | arg_string = "-compare" then do;
		if dev_sw then goto no_good;
		num_drives = 0;
		do l = 1 by 1;
		     k = k + 1;
		     if k > nargs then do;
			if l < 3 then do;
comp_error:
			     code = error_table_$noarg;
			     call com_err_ (code, "test_tape", "Must have at least 2 devices to run compatability!")
				;
			     go to bad_arg;
			     end;
			goto done_args;
			end;
		     call cu_$arg_ptr (k, argptr, arglen, code);
		     if index (arg_string, "-") ^= 0 then do;
			if l < 3 then goto comp_error;
			k = k - 1;
			goto next_arg;
			end;
		     if l > 16 then do;
			call com_err_ (error_table_$badopt, "test_tape", "16 drives is the max.");
			go to bad_arg;
			end;
		     dev_array (l) = arg_string;
		     comp_sw = "1"b;
		     num_drives = num_drives + 1;
		end;
		end;

/* See if sys flag is wanted */

	     if arg_string = "-system" | arg_string = "-sys" then do;
		sys_sw = "1"b;
		go to next_arg;
		end;

	     if arg_string = "-retry" then goto next_arg; /* Default (obsolete arg) */

	     code = error_table_$badopt;
	     call com_err_ (code, "test_tape", "Invalid or unrecognizable parameter in string (^a).", arg_string);

bad_arg:
	     call com_err_ (0, "test_tape", "For a list of valid control args type ""help test_tape -bf"".");
	     return;
next_arg:
	end;

done_args:
	tsegp = null ();				/* so cleanup will work */
	tdcm_attached = "0"b;
	on cleanup call command_cleanup ("0"b);
	rek = 0;

/* Display current options to user. */

	call com_err_ (0, name_stamp (),
	     "Opt= tk-^[7^;9^],den-^[800^]^[1600^]^[6250^],mode-^[w^]^[r^],ct-^[entire^s^;^d^]^[,wt-^d^;^s^],ptrn-^[random^s^;^12.3b^]^[,ndc^]^[,raw^]^[,sys^]",
	     track7, den8, den16, den6250, write_sw, read_sw, (ntimes >= 100000), ntimes, wait_flag, wait_cnt,
	     rand_ptrn, mask, ndc_sw, ext_sw, sys_sw);
%page;

/* init tape for write and get it mounted */


/* -------------------------------------------------------------------------------------------------- */
/*                                                                                                  */
/*     Grab storage for the tseg structure.                                                         */
/*                                                                                                  */
/* -------------------------------------------------------------------------------------------------- */

	comp_lp_ctr = 0;
	if comp_sw then do;
comp_loop:
	     comp_lp_ctr = comp_lp_ctr + 1;
	     dev_name = dev_array (comp_lp_ctr);
	     if comp_lp_ctr > 1 then write_sw = "0"b;	/* turn off write */
	     end;

	call get_temp_segment_ (name_stamp (), ext_bffr_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "Attempting to get a temporary segment!");
	     return;
	     end;
	allocate tseg;

	tseg.version_num = tseg_version_2;
	tseg.areap = null;
	call ipc_$create_ev_chn (tseg.ev_chan, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "no event channel");
	     go to done;
	     end;

	if track7
	then tseg.tracks = 1;			/* We want a 7 track drive */


	else tseg.tracks = 0;			/* we want a 9 track tape */
sync:
	tseg.sync = 1;				/* we want async operation */
	tseg.get_size = 0;				/* no sizes returned */


	tseg.bufferptr (1) = bin (rel (addr (tseg.buffer (1))), 18);
	tseg.buffer_size (1) = 1040;
	tseg.mode (1) = 0;				/* binary records */
	tseg.density = density;


/* ----------------------------------------------------------------------------------------------- */
/*                                                                                               */
/* Attach drive and do initial rewind and unload.  Prepare to wait for tape mounted signal.      */
/*                                                                                               */
/* ----------------------------------------------------------------------------------------------- */

	if write_sw
	then tseg.write_sw = 1;
	else tseg.write_sw = 0;

	call tdcm_$tdcm_attach (tsegp, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "tdcm attach bad");
	     go to done;
	     end;
	tdcm_attached = "1"b;

	call tdcm_$tdcm_set_signal (tsegp, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "mount tape set signal bad");
	     go to done;
	     end;


/* ------------------------------------------------------------------------------------------------------- */
/*                                                                                                       */
/*     Set the volume id and issue the starting test message to the user.  Output a mount message        */
/*     to the operator and hang around waiting for a response from him to indicate that the tape is      */
/*     indeed mounted.                                                                                   */
/*                                                                                                       */
/* ------------------------------------------------------------------------------------------------------- */

attach:
	tape_mounted = "0"b;			/* No tape YET */
	if dev_sw | comp_sw
	then tseg.drive_name = dev_name;
	else tseg.drive_name = "";

	if vid
	then reel_comment = rtrim (save_reel);

	else do;
	     reel_comment = "test-tape";
	     save_reel = "test-tape";
	     end;

	if comment_sw then reel_comment = rtrim (reel_comment) || ",*" || rtrim (comment);

	if sys_sw then reel_comment = rtrim (reel_comment) || ",sys";

request_mount:
	call com_err_ (0, name_stamp (), "Requesting mount of volume ""^a""^[ on ^a^].", save_reel, (dev_sw | comp_sw),
	     tseg.drive_name);

	call tdcm_$tdcm_message (tsegp, reel_comment, tseg.write_sw, code);
	if code ^= 0 & code ^= error_table_$resource_attached & code ^= error_table_$resource_assigned then do;
	     call com_err_ (code, name_stamp (), "Unable to attach ^a", tseg.drive_name);
	     if wait_flag & (wait_cnt > wait) & code = error_table_$resource_unavailable then do;
		call com_err_ (0, name_stamp (), "I will wait 1 minute and then try again!");
		call timer_manager_$sleep (60, "11"b);
		wait = wait + 1;
		goto request_mount;
		end;
	     wait = 0;
	     if comp_sw then do;
		if comp_lp_ctr = 1 then do;
		     call com_err_ (0, name_stamp (), "Unable to continue test.");
		     call command_cleanup ("1"b);
		     return;
		     end;
		call com_err_ (0, name_stamp (), "Bypassing device ^a.", tseg.drive_name);
		goto done;
		end;
	     call command_cleanup ("1"b);
	     return;
	     end;

	else if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "Attaching tape.");
	     go to done;
	     end;

	wait = 0;
	call wait_io;				/* wait for drive ext signal */

/* ------------------------------------------------------------------------------------------------------- */
/*                                                                                                       */
/*     When the tape is officially mounted set the density if requested to do so.                        */
/*                                                                                                       */
/* ------------------------------------------------------------------------------------------------------- */

	tape_mounted = "1"b;			/* now official */

	if den8 | den16 | den6250 then do;
	     set_den_sw = "1"b;
	     doing = "set density";
	     if den8 then tseg.command_queue (1) = bin ("110000"b, 6);
	     if den16 then tseg.command_queue (1) = bin ("110101"b, 6);
	     if den6250 then tseg.command_queue (1) = bin ("100001"b, 6);
	     tseg.sync = 1;
	     tseg.buffer_count = 0;
	     tseg.command_count = 1;
	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "Set density iocall failed.");
		go to done;
		end;


	     if tseg.completion_status = 1
	     then tseg.sync = 1;

	     else do;
		call ck_io (code, "0"b);
		call com_err_ (0, name_stamp (), "Set density io failed, terminating test.");
		go to done;
		end;
	     end;

	set_den_sw = "0"b;

	if ^buf_init then do;
	     if rand_ptrn then do;
		do i = 1 to 1040;
		     call random_$uniform (seed, num_ret);
		     bufarray (i) = unspec (num_ret);
		end;
		end;
	     else do i = 1 to 1040;
		bufarray (i) = mask;
	     end;

	     tseg.buffer (1) = buftemp;

	     buf_init = "1"b;
	     end;

	ws_ptr = baseptr (tseg.ws_segno);
	ioi_idx = ws.info.ioix;


	tseg.command_count = 2;
	tseg.command_queue (2) = bin ("100000"b, 6);	/* reset dev status */
	tseg.command_queue (1) = bin ("101001"b, 6);	/* reset device extended status */
	call tdcm_$tdcm_iocall (tsegp, code);
	recursive_ = -1;				/* prevent recursive calls */
	name = tseg.drive_name;

	on program_interrupt
	     call com_err_ (0, name_stamp (), "^a pass on ^a, processing record ^d", rtrim (doing),
		rtrim (tseg.drive_name), rek);


%page;

/* here we write test tape if requested, else go to read */

	if write_sw = "0"b then go to read_part;
	doing = "write";
	call com_err_ (0, name_stamp (), "Begin write pass on ^a^[ vol=^a^].", tseg.drive_name, vid, save_reel);

/*     Do this loop either till end of tape or until we reach the number of records specified  by the user in the -nrec parameter.        */


	rek, rec_wrt = 0;

	do i = 1 to ntimes;
	     rek = rek + 1;
	     wrx = i;
	     rec_wrt = rec_wrt + 1;

reissue_wr:
	     tseg.buffer (1) = buftemp;
	     call issue_rw;

	     if tseg.completion_status = 1 then go to write_ok;
						/* Completion Status was good */

	     stat_ptr = addr (tseg.hardware_status);

	     if stat_maj = "0001"b then go to reissue_wr;


	     call ck_io (code, "0"b);
	     if code = 1 then go to done;
	     if code = 3 then go to reissue_wr;
	     if code = 4 then go to eot_m;
	     if (code = 5) | (code = 9) then go to done;
	     if code = 6 then go to eot_m;


write_ok:
done_write:
	end;
%page;

eot_m:
	if code = 4
	then at_eot = "1"b;
	else at_eot = "0"b;
	doing = "write EOF";

	do i = 1 to 10;
	     tseg.buffer_count = 0;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = bin ("101101"b, 6);
	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "Write EOF^[ at EOT^;^] iocall failed.", at_eot);
		go to done;
		end;


	     if tseg.completion_status = 1
	     then go to write_second_eof;

	     else do;
		call ck_io (code, "0"b);
		if code = 4 then go to write_second_eof;
		call backspace (1);
		end;

	end;

	call com_err_ (0, name_stamp (), "Unable to write EOF^[ at EOT^;^], terminating test.", at_eot);
	go to done;


write_second_eof:
	doing = "write second EOF";

	do i = 1 to 10;
	     tseg.buffer_count = 0;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = bin ("101101"b, 6);
	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "Write second EOF^[ at EOT^;^] iocall failed.", at_eot);
		go to done;
		end;


	     if tseg.completion_status = 1
	     then go to rew;

	     else do;
		call ck_io (code, "0"b);
		if code = 4 then go to rew;
		call backspace (1);
		end;

	end;

	call com_err_ (0, name_stamp (), "Unable to write second EOF^[ at EOT^;^], terminating test.", at_eot);
	go to done;


rew:
	doing = "rewind";
	at_eot = "0"b;
	write_sw = "0"b;
	rew_sw = "1"b;

	do i = 1 to 5;
	     tseg.buffer_count = 0;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = bin ("111000"b, 6);

	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "rewind iocall failed");
		go to done;
		end;

	     if tseg.completion_status = 1 then go to wait_rew;

	     call ck_io (code, "0"b);			/*  got bad io stat */
	end;

	call com_err_ (0, name_stamp (), "Unable to issue rewind io, terminating test.");
	go to done;



wait_rew:
	do i = 1 to 120 while (rew_sw = "1"b);		/* Max = 10 minutes */

	     call timer_manager_$sleep (5, "11"b);	/* 5 relative seconds */
	     tseg.buffer_count = 0;
	     tseg.command_count = 1;
	     tseg.command_queue (1) = bin ("000000"b, 6);
	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "check status iocall failed.");
		go to done;
		end;

	     if tseg.completion_status = 1 then do;
		rew_sw = "0"b;
		go to read_part;
		end;

	     if (addr (tseg.hardware_status) -> stat_chk.stat_maj = "0001"b)
		& (addr (tseg.hardware_status) -> stat_chk.stat_min = "000001"b)
	     then go to end_wait;


	     if tseg.completion_status = 2 then call ck_io (code, "0"b);

end_wait:
	end;

	call com_err_ (code, name_stamp (), "unable to perform rewind on device");
	go to done;
%page;


/* here to read tape and check how we did */

read_part:
	if read_sw = "0"b then go to done;


	detected_eof = "0"b;
	write_sw = "0"b;
	doing = "read";
	call com_err_ (0, name_stamp (), "Begin read pass on ^a^[ vol=^a^].", tseg.drive_name, vid, save_reel);
	tseg.write_sw = 0;				/* lets setup to do a read */

	rec_rd = 0;
	rek = 0;					/* record number for s/b data */

	do i = 1 to ntimes;
	     rek = rek + 1;
	     rdx = i;
	     rec_rd = rec_rd + 1;


reissue_rd:
	     call issue_rw;

	     if tseg.completion_status = 1 then do;
		detected_eof = "0"b;
		if ^ndc_sw
		then call ck_data;
		else go to end_read;
		end;

	     stat_ptr = addr (tseg.hardware_status);

	     if stat_maj = "0001"b then go to reissue_rd;

	     if tseg.completion_status = 2 then do;

		if stat_maj = "0100"b then do;
		     if stat_min = "001111"b | stat_min = "010011"b then do;
						/* 7 or 9 track eof signal */
			rek = rek - 1;
			rdx = rdx - 1;
			rec_rd = rec_rd - 1;

			if detected_eof then goto done;
						/* this makes two in a row! */
			detected_eof = "1"b;	/* one seen */
			goto end_read;
			end;
		     rew_sw = "1"b;			/* set so no retries */
		     call ck_io (code, "1"b);		/* got a parity err */
		     go to done;
		     end;

		call ck_io (code, "1"b);		/* how was it */
		if code = 1 then go to done;
		if code = 4 then do;
		     call com_err_ (code, name_stamp (), "EOT detected during read");
		     go to done;
		     end;

		if (code = 5) | (code = 9) then do;
		     call com_err_ (code, name_stamp (), "Unrecoverable Attention condition, Quit.");
		     codex = 9;
		     go to done;
		     end;
		end;
	     go to end_read;

end_read:
	     blank_rd = 0;
	end;

done:
	call summarize;				/* display results */

	call command_cleanup ("1"b);

	if (comp_sw) & (comp_lp_ctr < num_drives) then do;
	     read_error, write_error, rd_comp_err = 0;
	     irrec_write, irrec_read = 0;
	     blank_rd, rec_wrt, rec_rd = 0;
	     da_cnt = 0;
	     goto comp_loop;
	     end;

	return;
%page;
error:
     proc (efail, ecode);
dcl  efail char (*) varying,
     ecode fixed bin (35),
     more_sw bit (1),
     recn fixed bin;
dcl  t_maj bit (6) init ("000000"b);
dcl  is_interesting bit (1);
dcl  detailed_stat bit (208) unal based (dstat_ptr);
dcl  1 ext based (dstat_ptr),
       2 data (26) bit (8) unal;


	if retry_in_progress &			/* bypass if in retry */
	     ^(code = 9 | code = 5)
	then return;
	if read_sw then recn = rdx;

	if write_sw then recn = wrx;

	if (rew_sw | set_den_sw)
	then more_sw = "1"b;
	else more_sw = "0"b;


	call com_err_ (0, name_stamp (), "^a error^[ @ record ^9d^].", doing, ^more_sw, recn);
	call ioa_ ("^-^3x^a (^2o/^2o)", efail, stat_maj, stat_min);


	dstat_ptr = addr (ext_bffr (da_cnt).ext_data);

	if code = 9 | code = 5 then do;		/* if its an att. cond. */
	     call analyze_detail_stat_$rsnnl (name, (tseg.hardware_status), detailed_stat, efail, is_interesting, ecode)
		;
	     if is_interesting then call ioa_ ("^-^3xDetailed status: ^a", efail);
	     end;


	if ext_sw then do;
	     call ioa_ ("^/Detailed Status: ^( ^2.4b^) (hex)", ext.data (1), ext.data (2), ext.data (3), ext.data (4),
		ext.data (5), ext.data (6), ext.data (7), ext.data (8), ext.data (9), ext.data (10), ext.data (11),
		ext.data (12), ext.data (13), ext.data (14), ext.data (15), ext.data (16));
	     call ioa_ ("^10xByte => 00 01 02 03 04 05 06 07 08 09 10 11 12 13 14 15^/");
	     call ioa_ ("^17x^( ^2.4b^) (hex)", ext.data (17), ext.data (18), ext.data (19), ext.data (20),
		ext.data (21), ext.data (22), ext.data (23), ext.data (24), ext.data (25), ext.data (26));
	     call ioa_ ("^10xByte => 16 17 18 19 20 21 22 23 24 25^/");
	     end;

	return;
     end error;
%page;

/* internal proc to determine type of error */

ck_io:
     proc (xcode, who_sw);

dcl  xcode fixed bin (35),
     stat_pad bit (36) aligned init ("0"b),
     who_sw bit (1);


	if tseg.completion_status ^= 2
	then					/* should not be here otherwise */
	     return;

	code = 0;					/* resett error status */


	if stat_maj = "0011"b & substr (stat_min, 1, 1) = "1"b then do;
						/* EOT Detected */
	     code = 4;
	     if stat_min ^= "100000"b then do;
		call analyze_device_stat_$rsnnl (fail, stat_tablep, (tseg.hardware_status || stat_pad), ("0"b));
		call error (fail, code);
		code = 2;
		end;
	     return;
	     end;

	if stat_maj = "0011"b & stat_min = "000010"b then do;
	     blank_rd = blank_rd + 1;
	     if blank_rd = 3 then do;
		call com_err_ (0, name_stamp (), "quitting test due to BLANK TAPE on READ statuses.");
		go to done;
		end;
	     end;

	call ioi_$get_detailed_status (ioi_idx, det_valid, rsr_data, code);
	if ^det_valid then rsr_data = "0"b;

	if tseg.write_sw = 1
	then					/* if we're  writing update the write errors */
	     write_error = write_error + 1;

	else read_error = read_error + 1;

	call analyze_device_stat_$rsnnl (fail, stat_tablep, (tseg.hardware_status || stat_pad), ("0"b));

	da_cnt = da_cnt + 1;			/* update error ctr */
	if da_cnt > 1000 then do;			/* too many errors */
	     call com_err_ (0, name_stamp (), "Too many errors encountered! ^/Fix tape drive and re-run!");
	     da_cnt = da_cnt - 1;			/* forget about this one */
	     call error (fail, code);
	     go to done;
	     end;


	ext_bffr (da_cnt).iom_status = tseg.hardware_status;
	ext_bffr (da_cnt).ext_data = substr (rsr_data, 1, 208);

	if tseg.write_sw = 1			/* if writing */
	then ext_bffr (da_cnt).xrec_no = wrx;

	else ext_bffr (da_cnt).xrec_no = rdx;

	ext_bffr (da_cnt).xdoing = tseg.write_sw;

check_stat:
	if stat_maj = "0011"b | stat_maj = "0010"b | stat_maj = "1011"b | stat_maj = "1010"b
	then go to err_stat (fixed (stat_maj, 4));

	else go to err_stat (9);


err_stat (3):					/* MTH Data Alert */
	code, codex = 2;
	call error (fail, code);
	if ^retry_in_progress then call retry_;
	return;

err_stat (11):					/* MPC Data Alert */
	if stat_min = "100000"b
	then code, codex = 9;			/* Marginal Condition */

	else code, codex = 2;
	call error (fail, code);
	if ^retry_in_progress then call retry_;
	return;


err_stat (10):					/* MPC Attention */
	code, codex = 9;

	if substr (stat_min, 3, 2) = "11"b then do;
	     code = 2;
	     call error (fail, code);
	     if ^retry_in_progress then call retry_;
	     return;
	     end;

	else if substr (stat_min, 3, 2) ^= "11"b then do;
	     code, codex = 9;
	     ext_sw = "1"b;
	     call error (fail, code);
	     ext_sw = "0"b;
	     go to done;
	     end;

err_stat (2):					/* MTH Attention */
	code, codex = 9;
	ext_sw = "1"b;
	call error (fail, code);
	ext_sw = "0"b;
	go to done;

/* should never get here. if we do report it and quit test */

err_stat (9):
	codex = 9;
	call com_err_ (0, name_stamp (), "Cannot process returned status, aborting test.");
	ext_sw = "1"b;
	call error (fail, code);
	ext_sw = "0"b;
	go to done;

     end ck_io;
%page;

retry_:
     proc;
dcl  (kntt, knt, gotit) fixed bin init (0);

	if index (doing, "EOT") ^= 0 then return;


	if rew_sw then return;

	retry_in_progress = "1"b;

	if doing = "write" then do;

	     do knt = 1 to 10;			/* allow  for 10 retries of a record */
		call backspace (1);

		call issue_rw;			/*  do the io */

		if tseg.completion_status = 1 then do;
		     code = 0;
		     retry_in_progress = "0"b;
		     return;
		     end;

		if tseg.completion_status = 2 then call ck_io (code, "0"b);

	     end;

	     irrec_write = irrec_write + 1;

/*  do a bksp/erase */

	     call com_err_ (0, name_stamp (), "10 unsuccessful attempts to write record ^d.", wrx);
	     call com_err_ (0, "", "^2-backspace/erase operation will be performed.");

	     tseg.command_count = 2;
	     tseg.command_queue (1) = bin ("100110"b, 6);
	     tseg.command_queue (2) = bin ("101100"b, 6);

	     call tdcm_$tdcm_iocall (tsegp, code);

	     if code ^= 0 then do;
		call com_err_ (code, name_stamp (), "backspace/erase  iocall failed, QUIT");
		go to done;
		end;

	     if tseg.completion_status = 1 then do;	/* good term */
		retry_in_progress = "0"b;
		code = 3;
		return;
		end;

	     else do;				/* abnormal term */

		call ck_io (code, "0"b);
		call com_err_ (0, name_stamp (), "backspace/erase failed, QUIT.");
		go to done;
		end;

	     retry_in_progress = "0"b;
	     end;					/* end of write retry */


	else do;					/* retry reads */

	     do knt = 1 to 3;			/* allow for 3 retries */
		call backspace (1);
		call issue_rw;

		if tseg.completion_status = 1 then do;	/* read ok */
		     call ck_data;			/* verify the data */
		     return;
		     end;

		else call ck_io (code, "1"b);
	     end;

	     call com_err_ (0, name_stamp (), "Unable to read record ^d.", rdx);
	     irrec_read = irrec_read + 1;
	     retry_in_progress = "0"b;
	     end;					/* end of read retry */
	retry_in_progress = "0"b;

	return;
     end retry_;


%page;

/* routine to issue read and write calls to tdcm */

issue_rw:
     proc;

	tseg.buffer_offset = 0;
	tseg.buffer_count = 1;
	tseg.command_count = 0;

	call tdcm_$tdcm_iocall (tsegp, code);


	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "^a iocall failed", doing);
	     go to done;
	     end;

	return;
     end issue_rw;

backspace:
     proc (n);

dcl  (i, n) fixed bin;

	tseg.command_count = n;

	do i = 1 to n;
	     tseg.command_queue (i) = bin ("100110"b, 6); /* backspace cmd */
	end;

	call tdcm_$tdcm_iocall (tsegp, code);

	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "backspace iocall failed.");
	     go to done;
	     end;

	tseg.command_count, code = 0;

	return;

     end backspace;
%page;
ck_data:
     proc;
dcl  kk fixed bin;

	if tseg.buffer (1) = buftemp
	then					/* if data compares */
	     return;				/*  all's well */

	rd_comp_err = rd_comp_err + 1;
	call com_err_ (0, name_stamp (), "data compare error at record  ^9d.", rdx);
	read_buff = tseg.buffer (1);
	do k = 1 to 1040;
	     if err_buff (k) ^= bufarray (k) then do;

		if k > 2
		then kk = k - 2;
		else kk = k;

		call ioa_ ("^/Data Word^9d^3x^9d^3x^9d^3x^9d", kk, kk + 1, kk + 2, kk + 3);
		call ioa_ ("Data Was:^4( ^.3b^)", err_buff (kk), err_buff (kk + 1), err_buff (kk + 2),
		     err_buff (kk + 3));
		call ioa_ ("Data S/B:^4( ^.3b^)^/", bufarray (kk), bufarray (kk + 1), bufarray (kk + 2),
		     bufarray (kk + 3));
		end;
	     return;
	end;

	return;
     end ck_data;
%page;
/* routine to wait for external signal form tape drine */

wait_io:
     proc;

	wait_list.n = 1;
	wait_list.chan (1) = tseg.ev_chan;
	call ipc_$block (addr (wait_list), addr (message), code);

	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "ipc_$block failed");
	     go to done;
	     end;

	doing = "wait io";
ck_ready:
	tseg.buffer_count = 0;
	tseg.command_count = 1;
	tseg.command_queue (1) = bin ("100000"b, 6);
	call tdcm_$tdcm_iocall (tsegp, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "status  check iocall bad");
	     go to done;
	     end;

	tseg.command_count = 0;			/* back to async */
	stat_ptr = addr (tseg.hardware_status);

	if stat_maj ^= "0000"b
	then if stat_min ^= "000010"b | stat_min ^= "000110"b then go to ck_ready;
	call tdcm_$tdcm_reset_signal (tsegp, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "reset signal bad");
	     go to done;
	     end;


	return;

     end wait_io;					/* end wait_io of wait_io  */
%page;
interp_xstats:
     proc;

dcl  tks fixed bin init (0);
dcl  valid bit (1) init ("0"b);
dcl  (i, j, k) fixed bin;
dcl  (xx, num_in_list) fixed bin init (0);
dcl  curr_dens fixed bin init (0);			/* current density */
dcl  ret_chars fixed bin (21);
dcl  analysis_string char (120);
dcl  message_hold char (1016) varying;
dcl  1 analysis_list (num_in_list) aligned based (a_list_ptr),
       2 mess_count fixed bin,
       2 message char (1016) varying;
dcl  (ext_ptr, a_list_ptr) ptr;
dcl  rec_mode (0:1) char (1) internal static options (constant) init ("R", "W");
dcl  (tracks_v, cmts) bit (1) init ("0"b);
dcl  my_analp ptr init (null ());
dcl  code fixed bin (35);
dcl  (
     ioa_$rs,
     ioa_$nnl
     ) entry () options (variable);

	if da_cnt < 1 then return;
	curr_dens = dens_ (fixed (substr (density, 3, 3), 3));
	att_bffr = ext_bffr (1).ext_data;
	call analyze_detail_stat_ (name, ext_bffr (1).iom_status, ext_bffr (1).ext_data, my_analp, code);
	if code ^= 0 then return;
	if my_analp = null () then return;
	tape_analp = my_analp;
	if ^tape_analysis.fips_controller then do;
	     i = fixed (substr (att_bffr, 21, 4), 4);
	     rec_cap = rec_tbl (i);

	     i = fixed (substr (att_bffr, 30, 2), 2);
	     dev_spd = spd_tbl (i);
	     end;
	else do;
	     if substr (att_bffr, 53, 1)
	     then rec_cap = "1600/6250";
	     else rec_cap = "800/1600/6250";
	     if substr (att_bffr, 54, 3) = "011"b then dev_spd = " 75 ips ";
	     else if substr (att_bffr, 54, 3) = "100"b then dev_spd = "125 ips ";
	     else if substr (att_bffr, 54, 3) = "101"b then dev_spd = "200 ips ";
	     else dev_spd = "??? ips ";
	     end;

	call ioa_ (
	     "^/Device is an ^a,^2x^d track;^2xCurrent Recording Mode:^x^4dbpi^/Recording Capability:^2x^abpi;^5xDevice Speed:^2x^a.^/",
	     tape_analysis.mth_model, tape_analysis.num_tracks, curr_dens, rec_cap, dev_spd);


	call ioa_ ("^xCount^4xRecd #^2xR/W^2xData Bit(s) in Error^2xOther Detail Status Bit Decodes");
	call ioa_ ("========^2x======^2x===^2x====================^2x===============================");

	call get_temp_segment_ ("test_tape", a_list_ptr, code);
	if code ^= 0 then do;
	     call com_err_ (code, name_stamp (), "Attempting to get a temporary segment!");
	     return;
	     end;

	do i = 1 to da_cnt;
	     call analyze_detail_stat_ (name, ext_bffr (i).iom_status, ext_bffr (i).ext_data, my_analp, code);

	     if code ^= 0 then return;
	     if my_analp = null () then return;
	     tape_analp = my_analp;

	     if tape_analysis.num_analyzed > 0 then cmts = "1"b;

	     call ioa_$rs ("^6d^3x^1a^4x^18a^[^37t^a^]", analysis_string, ret_chars, ext_bffr (i).xrec_no,
		rec_mode (ext_bffr (i).xdoing), tape_analysis.tracks_in_error, cmts,
		rtrim (tape_analysis.analyses (1)));
	     message_hold = substr (analysis_string, 1, ret_chars);

	     do j = 2 to tape_analysis.num_analyzed;
		call ioa_$rs ("^47t^a", analysis_string, ret_chars, rtrim (tape_analysis.analyses (j)));
		message_hold = message_hold || substr (analysis_string, 1, ret_chars);
	     end;

	     do k = 1 to num_in_list;
		if analysis_list (k).message = message_hold then do;
		     analysis_list (k).mess_count = analysis_list (k).mess_count + 1;
		     goto next_xstats;
		     end;
	     end;
	     num_in_list = k;
	     analysis_list (k).mess_count = 1;
	     analysis_list (k).message = message_hold;
next_xstats:
	end;

	do k = 1 to num_in_list;
	     call ioa_$nnl ("^7d^3x^a", analysis_list (k).mess_count, analysis_list (k).message);
	end;

	call release_temp_segment_ (name_stamp (), a_list_ptr, code);
end_xstat:
	return;
     end interp_xstats;

%page;

command_cleanup:
     proc (term_condition);
dcl  term_condition bit (1);				/* 1 = just cleanup */
						/* 0 = display results and clean */

	if tsegp ^= null () then do;
	     if tape_mounted then do;
		tseg.command_count = 1;
		tseg.buffer_count = 0;
		tseg.command_queue (1) = bin ("111000"b, 6);
						/* rewind */
		call tdcm_$tdcm_iocall (tsegp, code);
		if ^term_condition then call summarize;
		tape_mounted = "0"b;		/* really still is! */
		end;
	     if tdcm_attached then do;
		call tdcm_$tdcm_detach (tsegp, code);
		tdcm_attached = "0"b;
		end;
	     free tseg;
	     end;
	if ext_bffr_ptr ^= null () then call release_temp_segment_ ("test_tape", ext_bffr_ptr, code);
	recursive_ = 0;

	return;

     end command_cleanup;
%page;
summarize:
     proc;
	if ^tape_mounted then return;			/* never got off the ground */
	call com_err_ (0, name_stamp (), "Test Complete on ^a^2xvol=^a (^4dbpi)", rtrim (name), rtrim (save_reel),
	     dens_ (fixed (substr (density, 3, 3), 3)));
	call ioa_ ("^/^/Records Written  ^9d", rec_wrt);
	call ioa_ ("Records Read     ^9d", rec_rd);

	yy = read_error + write_error + rd_comp_err;

	if yy = 0 then do;
	     call ioa_ ("^/No read/write errors encountered in test.^/");
	     return;
	     end;


	call ioa_ ("^14tRecoverable  Non-Recoverable");
	call ioa_ ("Write Errors^5x^7d^6x^11d", write_error, irrec_write);
	call ioa_ ("Read  Errors^5x^7d^6x^11d", read_error, irrec_read);
	call ioa_ ("Data Compare Errs^7d^/", rd_comp_err);
	call interp_xstats;
	call ioa_ ("^2/");

     end summarize;
%page;
name_stamp:
     proc () returns (char (17));
dcl  1 the_time unaligned int static,
       2 hour pic "99",
       2 minute pic "99",
       2 dot char (1) init ("."),
       2 tenth pic "9";

dcl  (clock, string, divide) builtin;
dcl  ec fixed bin (35);				/* use this, not "code" */
dcl  (hour_bin, minute_bin, second) fixed bin;
dcl  micro_second fixed bin (71);
dcl  decode_clock_value_$time
	entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), char (3), fixed bin (35));

	call decode_clock_value_$time (clock (), hour_bin, minute_bin, second, micro_second, "", ec);
	the_time.hour = hour_bin;
	the_time.minute = minute_bin;
	the_time.tenth = divide (second, 6, 17, 0);
	return ("test_tape: " || string (the_time));
     end name_stamp;
%page;
%include tdcm_info;
%page;
%include ioi_stat;
%page;
%include tseg;
%page;
%include analyze_det_stat_info;

     end test_tape;






		    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