



		    display_volume_log.pl1          11/11/89  1129.5rew 11/11/89  0851.4       95229



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

/****^  HISTORY COMMENTS:
  1) change(88-03-01,GWMay), approve(89-10-03,MCR8135),
     audit(89-10-04,Beattie), install(89-10-18,MR12.3-1094:
     Changed to display reload group numbers correctly.
     Added displays for the number of incr and cons cycles are
     being retained in the volume log.
     Changed to display at 79 columns.
     Changed to add the -label, -no_label, -all and -header options.
                                                   END HISTORY COMMENTS */

/* format: off */
display_volume_log: proc;

/* This command displays the data in the specified volume log. This data consists
   of the names, start and stop times, and statistics about what was dumped onto each dump volume that contains
   objects from the physical volume that this volume log pertains to.

*/
/* Modified 4/27/82 by GA Texada to not REQUIRE w acces to display the volog.	  */
%page;
       myname = "display_volume_log";
       go to COMMON;

display_volog: entry;

       myname = "display_volog";
       go to COMMON;

dvl: entry;

       myname = "dvl";

COMMON:
/* init control variables */
	header_sw = "1"b;
	type = 0;
	volname = "";
	bvlp = null;
	entries = 0;
	seg_num, seg_rec, dir_num, dir_rec = 0;
	locked, stats, label_sw, all_sw = "0"b;

	on finish call finish_;
	on cleanup call finish_;
	volog_dir = ">daemon_dir_dir>volume_backup";
	call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0 then do;

argerr:	     call com_err_ (error_table_$noarg, myname);
	     call ioa_ (
"Usage:^10t^a volog {-control_args}
^10tcontrol_args:^25t^a^-^a^/^25t^a^-^a^/^25t^a^-^a^/^25t^a^-^a^/^25t^a^-^a^/^25t^a",
	        myname,
	        "-incremental, -incr     ", "-header, -he            ",
	        "-consolidated, -cons    ", "-no_header, -nhe        ",
	        "-complete, -comp        ", "-label, -lbl            ",
	        "-volname name, -vol name", "-no_label, -nlbl        ",
	        "-working_dir, -wd       ", "-status, -st            ",
	        "-all, -a                ");
	     return;
	end;
	if substr (arg, 1, 1) = "-" then goto argerr;

	call expand_pathname_$add_suffix(arg, "volog", ignore_dir, volog_name, ignore); 
	
	call cu_$arg_count (narg);
	ac = 2;
	do while (ac <= narg);
	     call cu_$arg_ptr (ac, argp, argl, code);
	     if code ^= 0 then do;
		call com_err_ (code, myname, "Unable to access arg after ^a", arg);
		goto finale;
	     end;
	     if arg = "-incremental" | arg = "-incr" then type = incr;
	     else if arg = "-working_dir" | arg = "-wd" then volog_dir = wdir_ ();
	     else if arg = "-consolidated" | arg = "-cons" then type = cons;
	     else if arg = "-complete" | arg = "-comp" then type = comp;
	     else if arg = "-all" | arg = "-a" then all_sw = "1"b;
	     else if arg = "-header" | arg = "-he" then header_sw = "1"b;
	     else if arg = "-nhe" | arg = "-no_header" then header_sw = "0"b;
	     else if arg = "-label" | arg = "-lbl" then label_sw = "1"b;
	     else if arg = "-no_label" | arg = "-nlbl" then label_sw = "0"b;
	     else if arg = "-status" | arg = "-st" | arg = "-stats" then do;
		type = -1;
		stats = "1"b;
	     end;
	     else if arg = "-vol" | arg = "-volname" then do;
		ac = ac + 1;
		call cu_$arg_ptr (ac, argp, argl, code);
		if code ^= 0 then do;
		     call com_err_ (code, myname, "Error getting volname");
		     goto finale;
		end;
		volname = arg;
		type = -1;
	     end;
	     else do;
		call com_err_ (error_table_$badopt, myname, "^a", arg);
		goto finale;
	     end;
	     ac = ac + 1;
	end;

						/* pick up name of volume log */
						/* get pointer to volume log */
	call hcs_$initiate (volog_dir, volog_name, "", 0, 0, bvlp, code);
	if bvlp = null then do;
	     call com_err_ (code, myname, "^a>^a", volog_dir, volog_name);
	     goto finale;
	end;

/* If possible, lock log before printing */

          call set_lock_$lock (backup_volume_log.lock, lock_wait_time, code);
	if code ^= 0 then do;
	     if code = error_table_$invalid_lock_reset then code = 0;
	     else do;
		if code = error_table_$no_w_permission then do;
		call ioa_("Unable to lock ^a, data may be in the process of being changed.", volog_name);
		goto cant_lock;
		end;
	     call com_err_ (code, myname, "Unable to lock volog ^a", volog_name);
	     goto finale;
	     end;
	end;
          locked = "1"b;
cant_lock:
          if label_sw | all_sw then do;
	   call ioa_ ("
Backup Volume Log Label for Multics Storage System Volume ^a^/",
	      volog_name);
	   call display_disk_label_ (addr (addr (backup_volume_log.info) -> backup_pvol_info.label));
	   if ^all_sw & type=0 then go to finale;
	   end;

	if header_sw then do;
	     call ioa_ ("
^2-Backup Volume Log for Physical Volume ^a
^2-       Consolidated Sets Saved: ^[all^s^;^d^]
^2-       Incremental Sets Saved : ^[all^s^;^d^]
^2-       Reload Groups          : ^d",
	        reverse(after(reverse(volog_name), ".")),
	        backup_volume_log.Nsaved_cons_sets < 1,
	        backup_volume_log.Nsaved_cons_sets,
	        backup_volume_log.Nsaved_incr_sets < 1,
	        backup_volume_log.Nsaved_incr_sets,
	        backup_volume_log.reload_groups);

	     if ^stats then
		call ioa_ ("
rld dump  volume^57tdir   dir   seg    seg
grp type  name^22tstart time^39tstop time^57tnum   rec   num    rec");
	     else call ioa_ ("entries^-dir num^-dir rec^-seg num^-seg rec");
	     end;
          else
	   call ioa_ ("");

						/* Examine each entry in the log and print as requested */
	comp_cycle_uid = "0"b;
	group = 1;
	comp_open_time = 0;

	do i = backup_volume_log.next to 1 by -1;
	     bvlep = addr (backup_volume_log.array (i));
	     if (volname ^= "" & volname = bvle.volname) | (volname = "")
	     | stats then do;
	        if bvle.dump_type = comp then do;
		   if bvle.cycle_uid ^= comp_cycle_uid then do;
		      if comp_cycle_uid ^= "0"b then
		         group = group + 1;
		      comp_cycle_uid = bvle.cycle_uid;

		      do lowest_start_idx = i to 1 by -1;
		         if backup_volume_log.array (lowest_start_idx).cycle_uid = bvle.cycle_uid then
			  comp_open_time = backup_volume_log.array (lowest_start_idx).open_time;
		         end;
		      end;
		   end;

                    if ^stats then
                       if type = 0 | type = bvle.dump_type then
		      call ioa_ ("^[^2d^s^;^s^2d^]  ^4a  ^10a^22t^15a^39t^15a^55t^5d ^5d ^5d ^6d",
   		         (comp_open_time < bvle.close_time & bvle.close_time > 0), group, group + 1,
 		         ascii_type (bvle.dump_type), bvle.volname, time_string_ (bvle.open_time),
		         time_string_ (bvle.close_time), bvle.dir_num, bvle.dir_rec, bvle.seg_num, bvle.seg_rec);
                       else;
		else do;
		     entries = entries + 1;
		     dir_num = dir_num + bvle.dir_num;
		     dir_rec = dir_rec + bvle.dir_rec;
		     seg_num = seg_num + bvle.seg_num;
		     seg_rec = seg_rec + bvle.seg_rec;
		end;
	     end;
	end;

	if stats then call ioa_ ("^d^-^d^-^d^-^d^-^d",
	     entries, dir_num, dir_rec, seg_num, seg_rec);
finale:						/* cleanup - unlock and terminate */
	call finish_;
	return;

time_string_: proc (time) returns (char (15));

/* This proc returns a time string suitable for printing */

dcl  time fixed bin (71);
	    return (date_time_$format (
	        "^my/^dm/^yc ^Hd^99v.9MH", time, "", ""));
	end time_string_;

finish_:	proc;
	     if (bvlp ^= null) & (locked) then call set_lock_$unlock (backup_volume_log.lock, ignore);
	     if bvlp ^= null then call hcs_$terminate_noname (bvlp, ignore);
	     call ioa_ ("");
	end finish_;
wdir_:	proc returns (char (168) aligned);

/* This proc returns the working directory */

dcl  wdir char (168) aligned;
	     call hcs_$fs_search_get_wdir (addr (wdir), ignore);
	     return (wdir);
	end wdir_;
%page;
dcl  volog_name char (32);
dcl  lowest_start_idx fixed bin;
dcl  group fixed bin;
dcl  comp_cycle_uid bit (36);
dcl  comp_open_time fixed bin (71);
dcl  narg fixed bin;
dcl  volog_dir char (168);
dcl  arg char (argl) based (argp);
dcl  argl fixed bin;
dcl  argp ptr;
dcl  i fixed bin;
dcl  ac fixed bin;
dcl  ignore_dir char(168);
dcl  volname char (32);
dcl  seg_num fixed bin;
dcl  seg_rec fixed bin;
dcl  entries fixed bin;
dcl  dir_rec fixed bin;
dcl  dir_num fixed bin;
dcl  stats bit (1);
dcl  code fixed bin (35);
dcl  ignore fixed bin (35);
dcl  type fixed bin;
dcl  header_sw bit (1);
dcl  label_sw bit (1);
dcl  all_sw bit (1);
dcl  locked bit(1);
dcl  myname char (32) var;		
dcl  ascii_type (3) char (4) int static init ("incr", "cons", "comp") options(constant);
dcl  lock_wait_time fixed bin static init(30) options(constant);

dcl  hcs_$fs_search_get_wdir entry (ptr, fixed bin (35));
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl  com_err_ entry options (variable);
dcl  display_disk_label_ entry (ptr);
dcl  expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
dcl  hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  ioa_ entry options (variable);
dcl  date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var);
dcl  set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl  set_lock_$unlock entry (bit (36) aligned, fixed bin (35));
dcl  cu_$arg_count entry (fixed bin);

dcl  error_table_$badopt ext fixed bin (35);
dcl  error_table_$invalid_lock_reset ext fixed bin (35);
dcl  error_table_$noarg fixed bin(35) ext static;
dcl  error_table_$no_w_permission ext static fixed bin(35);
dcl (finish, cleanup) condition;

dcl (null, addr, after, reverse, substr) builtin;
%page;
%include backup_volume_log;
%include backup_pvol_info;
%include fs_vol_label;
%include backup_volume_header;
%include backup_static_variables;

     end display_volume_log;




		    rdisk_.pl1                      11/11/89  1129.5rew 11/11/89  0851.4     1035666



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



/****^  HISTORY COMMENTS:
  1) change(85-09-09,Farley), approve(85-09-09,MCR6979),
     audit(86-02-21,Coppola), install(86-03-21,MR12.0-1033):
     Support the IBM3380
     remove support of MSU0509.
  2) change(86-01-16,Fawcett), approve(86-04-11,MCR7383),
     audit(86-06-06,GWMay), install(86-07-17,MR12.0-1097):
     Add support for subvolumes, and 512_WORD_IO, 3380 and 3390.
  3) change(86-10-02,Fawcett), approve(86-10-02,PBF7383),
     audit(86-10-23,Farley), install(86-10-28,MR12.0-1200):
     Changed 3390 to 3381, "d338" to "3380" & "d339" to "3381".
  4) change(87-03-31,Blair), approve(87-03-31,MCR7666),
     audit(87-06-25,Fawcett), install(87-07-15,MR12.1-1041):
     Change the setup for Stream_output to equate to put_chars instead of
     get_chars.
                                                   END HISTORY COMMENTS */


/* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indend,dclind5,idind32 */
rdisk_:
     proc;
	return;					/*  should never enter here  */


/*  MODIFICATION HISTORY:

   Initially coded by J. A. Weeldreyer -- March, 1975.
   Modified to conform to new ioi_ interface by J. A. Weeldreyer -- April, 1975.
   Modified to conform to the  rcp_ interface by J. A. Weeldreyer -- July, 1975.
   modified -- December, 1975 by J. A. Bush to add the raw mode and  the
   format_trk, rd_trk_header, and device_info control orders.
   Modified to support the new io_call control mechanism By L. E. Johnson -- May, 1976
   Modified to provide sequential_(input output update) opening modes,
   position operation, write_record operation, and more device types
   by Jim Gildersleeve and Jim Falksen -- 1976 June.
   Modified by D. R. Vinograd to provide limited stream
   support for the volume reloader. - July 1976
   Modified by Michael R. Jordan on 01/31/79 for MSU0500s
   Modified 9/79 by R.J.C. Kissel for MSU0501's.
   Modified 11/79 by Michael R. Jordan for MSU0500 formatting.
   Modified 1/80 by Michael R. Jordan to add -device and -model control arguments.
   Modified 2/80 by Michael R. Jordan for MSU0501 and bug fixes.
   Modified May 1982 by J. Bongiovanni for larger buffers
   Modified 3/83 by GA Texada for changes made by W. Olin Sibert to make
		large buffers work and assorted other bugfixes.
*/


/*  DESCRIPTION:

   *	     This  I/O  module supports I/O from/to removable disk packs.
   *	Sequential and indexed file types are supported.
   *
   *	     Entries in this module are not  called  directly  by  users;
   *	rather,  the  module is accessed through the I/O system.  See the
   *	MPM section, the Multics I/O System, for a general description of
   *	the I/O system,  and  see  the  MPM  section,  File  I/O,  for  a
   *	discussion of files.
   *
   *	     This  I/O module provides a very elementary, physical device
   *	oriented I/O facility, and is the basic user-level interface to a
   *	disk device.  All  operations  are  performed  through  calls  to
   *	various I/O Interfacer (ioi_) and Resource Control Package (rcp_)
   *	entries.   This  I/O module provides the capability to read/write
   *	a caller-specified number  of  characters  to/from  a  disk_pack.
   *	Supported device types are  DSU181, DSU190, DSU191, MSU0400,
   *	MSU0451, MSU0500, MSU0501, MSU3380 and MSU3381.
*/

/*  NOTES:

*/

%include iocbx;

%include iom_pcw;

%include iom_dcw;

%include track_header_info;

%include rcp_disk_info;

%include fs_dev_types;

%include iox_modes;

dcl  1 disk_data		       based (disk_ptr),	/*  rdisk_ 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  rdisk_  */
         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/90 */
         3 is_sv		       bit (1),		/* attach subvolume */
         3 sv_num		       fixed bin,		/* attached subvolume number */
         3 att_dev_idx	       fixed bin,		/* index into attachments array for this device */
         3 att_sv_idx	       fixed bin,		/* index into attachments array of this device subvolume */
       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 rdisk_ 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 (71),	/* 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 attachments		       based (attachments_ptr),
       2 number_attached	       fixed bin,
       2 number_used	       fixed bin,
       2 array		       (100),
         3 device_att	       char (8),
         3 sv		       (3),
	 4 this_sv	       fixed bin,
	 4 this_iocbp	       ptr;

dcl  attachments_ptr	       ptr static init (null ());
dcl  system_area_ptr	       ptr;
dcl  system_area		       area based (system_area_ptr);
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		       (70),
         rsr_idcw,
         rsr_dcw
         )		       bit (36) aligned,	/* DCW's */
         3 seek_data	       like seek,		/* Information for seek DCW */
         3 rsr_data		       bit (72) unal,	/* detailed device status read by RSR */
         3 reserved		       (6) 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  1 query_info		       aligned,		/* command_query_ information */
       2 version		       fixed bin init (2),
       2 yes_or_no_sw	       bit (1) unal init ("1"b),
						/* want only "yes" or "no" */
       2 suppress_name_sw	       bit (1) unal init ("0"b),
						/* let them  know who we are */
       2 (status_code, query_code)   fixed bin (35) init (0);

dcl  pri_iocb_ptr		       ptr;
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, tot_rec_len, data_left, mode_len, mode_start)
			       fixed bin (35);
dcl  key			       fixed bin (21);	/* working seek key */
dcl  control_command	       bit (6);		/* data xfer command in execution */
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, j, num_opts, err_ct, old_length, new_length, rcp_state)
			       fixed bin;
dcl  (cyl, head)		       fixed bin (16);
dcl  (again, not_sw, mode_err_sw, cont_sw)
			       bit (1) unal;
dcl  answer		       char (3) varying;
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  old_descrip		       char (168);		/* hold area for changing attach descrip. */
dcl  new_pack_id		       char (32) varying based (info_ptr);
						/* new pack id for changepack order */
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_size		       fixed bin (35) based (info_ptr);
						/* new size for setsize control order */
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 */


dcl  DEVICE_GROUP		       (9) fixed bin int static options (constant) init (0, 2, 1, 1, 1, 1, 2, 3, 3);
						/* "bulk", "d500", "d451", "d400", "d190", "d181", "d501", "3380", "3381" */
dcl  FORMAT_DATA_LEN	       (9) fixed bin int static options (constant) init (0, 88, 6, 6, 6, 6, 24, 24, 24);
dcl  MSU04XX		       fixed bin int static options (constant) init (1);

dcl  MSU33XX		       fixed bin init static options (constant) init (3);
dcl  overhead		       fixed bin int static options (constant) init (192);
						/* number of control words reserved in ioi_ buffer */
dcl  max_retries		       int static options (constant) fixed bin init (10);
						/* number of times we will retry certain operations */
dcl  ATTENTION		       int static options (constant) bit (4) init ("0010"b);
dcl  EOF			       int static options (constant) bit (4) init ("0100"b);
dcl  LAST_BLOCK		       int static options (constant) bit (6) init ("000001"b);
dcl  LAST_BLOCK_MASK	       int static options (constant) bit (6) init ("111101"b);
dcl  TI_MASK		       int static options (constant) bit (6) init ("011100"b);
dcl  STANDBY		       int static options (constant) bit (6) init ("010000"b);
dcl  EXEC			       bit (5) int static options (constant) init ("00100"b);
dcl  FORMAT_TRK		       bit (6) int static options (constant) init ("001111"b);
dcl  RD_TRK_HEADER		       bit (6) int static options (constant) init ("010111"b);
dcl  SPECIAL_SEEK		       bit (6) int static options (constant) init ("011110"b);
dcl  SPECIAL_SEEK_512	       bit (6) int static options (constant) init ("35"b3);
dcl  LONG_WAIT		       fixed bin int static options (constant) init (2);
dcl  COMPLETE		       fixed bin int static options (constant) init (0);
dcl  RETAIN		       bit (1) int static options (constant) init ("1"b);
dcl  DEFAULT		       bit (1) int static options (constant) init ("0"b);
dcl  NOT_SET		       fixed bin (6) int static options (constant) init (-1);
dcl  num_label_sect		       fixed bin int static options (constant) init (8);
dcl  rcp_dev_type		       char (32) int static options (constant) init ("disk_drive");
dcl  IOTD			       bit (2) aligned int static options (constant) init ("00"b);
dcl  MAX_DCW_TALLY		       fixed bin int static options (constant) init (4096);


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  control_idcw_string	       int static bit (36) init ("000000700000"b3);
dcl  read_write_dcw_string	       int static bit (36) init ("000000010000"b3);
						/* IOTP */
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_idcw_template	       defined (write_idcw_string) like idcw;
dcl  1 write_and_compare_idcw_template
			       defined (write_and_compare_idcw_string) like idcw;
dcl  1 control_idcw_template	       defined (control_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_conversion,			/*  bad_conv, Error in conversion.;  */
     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_$end_of_info,			/*  eoi     , End of information reached.;  */
     error_table_$incompatible_attach,			/*  att^=opn, Attach and open are incompatible.;  */
     error_table_$invalid_device,			/*  invdev  , Attempt to attach to an invalid device.;  */
     error_table_$invalid_read,			/*  invread , Attempt to read or move read pointer on device which was not attached as readable.;  */
     error_table_$invalid_write,			/*  invwrite, Attempt to write or move write pointer on device which was not attached as writeable.;  */
     error_table_$no_current_record,			/*  fm_16   , no_current_record := there is no current record.;  */
     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_$resource_assigned,
     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  (abs, addr, addrel, bin, bit, bool, ceil, char, divide, fixed, floor, hbound, index, length, max, min, mod, null,
     rel, search, size, string, substr, unspec, ltrim, rtrim, verify)
			       builtin;
dcl  get_system_free_area_	       entry () returns (ptr);
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  sub_err_		       entry options (variable);

/*  The above sub_err_ line used to be for com_err_ but clarification on the rules for writing
   *  I/O modules resulted in two significant decisions:
   *     (1) I/O modules should use the sub_err_ subroutine, not the com_err subroutine.
   *     (2) I/O modules should call sub_err_ _o_n_l_y in their attach routine,
   *         and then only if the value of the third argument equals "1"b.
   *  The next  "dcl"  statement is associated with sub_err_
   */
dcl  retval		       fixed bin (35);	/* value returned from caller specifying rdisk_ action */
						/* No actions in rdisk_ are defined at the moment. */
						/* When actions are defined, which value yields what */
						/* action could be listed here.  */


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  ioa_$ioa_stream	       entry options (variable);
dcl  command_query_		       entry options (variable);
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  iox_$control		       entry (ptr, char (*), ptr, 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  1 fmt_dta		       based (fmdp) aligned,	/* data needed by the format trk command */
       2 svcyl		       bit (16) unaligned,	/* seek verification  data cylinder number */
       2 svhd		       bit (16) unaligned,	/* seek verification data head number */
       2 hz		       bit (2) unaligned,	/* header bypass switch */
       2 ti		       bit (2) unaligned,	/* track indicator bits */
       2 pad1		       bit (10) unaligned,
       2 r0cti		       bit (2) unaligned,	/* record zero track indicators */
       2 r0ccyl		       bit (16) unaligned,	/* record zero count field - cyl number */
       2 r0chd		       bit (16) unaligned,	/* record zero count field - head number */
       2 pad2		       bit (2) unaligned,
       2 chk_chr		       bit (6) unaligned,	/* exclusive or check character  */
       2 pad3		       bit (12) unaligned,
       2 pad4		       bit (72) unaligned;

dcl  1 fmt_info		       based (info_ptr) 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  info_block		       char (20) based (info_ptr);
						/* users info buffer for rd_trk_header order */

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  user_hardware_status	       bit (72) based (info_ptr);

dcl  io_command		       char (8) varying;	/* values are "read", "write", or "rewrite" */
dcl  current_mode_name	       char (24);		/* name of current opening mode */

dcl  dcwx			       fixed bin;
dcl  dcw_address		       fixed bin (18);
dcl  rw_length		       fixed bin (18);

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);

/*  Start of ATTACH module  */

rdisk_attach:
     entry (a_iocb_ptr, options, a_err_sw, a_code);

/*
   *	     The attach description has the following form:
   *
   *	     rdisk_ device_id pack_id -opt1_- -opt_n-
   *
   *      1.   device_id      is a character string identifying the type  number
   *                          of  the  required disk device.  The supported disk
   *                          devices are listed in the table below, along  with
   *                          the character string to use for device_id:

   *                          device_id
   *                          Character
   *                          String              Device Type
   *                          __________          ___________________

   *                          d181                DSU181
   *                          d190                DSU190
   *                          d191                DSU190 with the
   *                                                high-efficiency format
   *                                                (40 sectors/track)
   *                          d400                MSU0400
   *                          d451                MSU0451
   *			d500		MSU0500
   * 			d501		MSU0501
   *			3380		MSU3380
   *			3381		MSU3381
   *
   *	      2.  pack_id             is a character  string  identifying
   *				the disk pack to be mounted.
   *
   *	      3.  opt_i                may  be  one   of   the   following
   *				options.   An option may occur only
   *				once.
   *
   *                -device device_name    Indicate what device the user is
   *				requesting. The device_name format is:
   *				dskX_NN{S}. Where X is the subsystem
   *				name, NN is the device number, and S
   *				the optional subvolume name. If S is 
   *				given then the seeks will be relative
   *				to the indicated subvolume.
   *
   *		-write              indicates that the disk pack is  to
   *				be   written.    If   omitted,  the
   *				operator  will  be  instructed   to
   *				mount the pack write inhibited.
   *
   *		-size n             indicates that the value of n is to
   *				override the value of buff_len as a
   *				record    size    limit   for   the
   *				read_record    operation.
   *
   *	       -system, -sys         indicates that the attachment  is  being
   *		                    made by a system process and that a disk
   *		                    drive  reserved  for system functions is
   *		                    to be assigned.
   *
   *		                    (NOTE:  This control argument used to be
   *		                    supplied by the user as "-priv"  but  is
   *		                    being  changed  to  "-system"  for  greater
   *		                    consistency with other parts of Multics.
   *		                    The character  string  "-priv"  will  be
   *		                    honored  for  awhile,  i.e., both "-system"
   *		                    and "-priv" will have  the  same  effect
   *		                    for  now.   With  some  future  release,
   *		                    "-priv" will no longer be accepted.)
   *
   *	     The  attachment causes the specified disk pack to be mounted
   *	on a drive of the specified type.  (See the IOI and RCP documentation.)
*/

dcl  options		       (*) char (*) varying;	/* parameter:  attach description elements */
dcl  a_err_sw		       bit (1) aligned;	/* parameter: print errors flag */
dcl  found_dev_att		       bit (1);
dcl  rcp_detachment		       bit (1);


	if attachments_ptr = null ()
	     then do;				/* If there is no attachments get the space */
		system_area_ptr = get_system_free_area_ ();
		allocate attachments in (system_area) set (attachments_ptr);
		attachments.device_att (*) = "";
		attachments.array (*).sv (*).this_iocbp = null ();
		attachments.number_used = 0;
		attachments.number_attached = 0;
	     end;


	code = 0;					/* clear return code */

	unique_entry_name = unique_chars_ ("0"b) || ".rdisk_";
	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 */

	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 */
	call parse_attach_options;

	if is_sv
	     then if attach_data.dev_type ^= 0
		     then if sv_num >= number_of_sv (attach_data.dev_type)
			     then call att_err (error_table_$invalid_device);
	if attach_data.dev_type = 0
	     then attach_descrip.descrip = "rdisk_ """" " || pack_id;
	     else attach_descrip.descrip =
		     "rdisk_ " || device_names (attach_data.dev_type) || " " || attach_data.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;

	if ^(found_dev_att)
	     then do;
		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;
	     end;
	disk_info.device_name = substr (drive_name, 1, 7);
	disk_info.write_flag = disk_data.write_sw;
	raw_sw = "0"b;				/* reset raw mode if set */
	alt_sw = "0"b;
	label_sw = "1"b;
	if ^found_dev_att
	     then do;
		call mount ();			/* attach drive, and mount pack */
		if code ^= 0 then call att_err (code);	/* complain if we didn't make it */

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

		if disk_data.dev_type <= 1 then call att_err (error_table_$invalid_device);

		device_group = DEVICE_GROUP (disk_data.dev_type);

		if disk_data.is_sv
		     then disk_data.sect_per_dev = sect_per_sv (disk_data.dev_type);
		     else disk_data.sect_per_dev =
			     sect_per_cyl (disk_data.dev_type) * cyl_per_dev (disk_data.dev_type);
						/* Set up device specific constants */
		disk_data.sect_size = words_per_sect (disk_data.dev_type);
		disk_data.num_alt_sect =
		     last_alt_sect_num (disk_data.dev_type) - first_alt_sect_num (disk_data.dev_type) + 1;

		if sys_sw
		     then disk_data.bounds.low = 0;
		     else disk_data.bounds.low = num_label_sect;
						/* initialize the seek low bound */
		if disk_data.device_group = MSU04XX
		     then disk_data.bounds.high = last_alt_sect_num (disk_data.dev_type);
		else if (disk_data.device_group = MSU33XX) & disk_data.is_sv
		     then disk_data.bounds.high = sect_per_sv (disk_data.dev_type) - 1;
		else disk_data.bounds.high = last_sect_num (disk_data.dev_type);
	     end;
	     else do;
		disk_data.errors = 0;		/* give the pack a fresh start */
		disk_data.buf_len = min (max (divide (disk_data.sze, 4, 17, 0), 1024), disk_data.max_buff_size);
						/* determine ioi_ buffer size */
		disk_data.data_len = disk_data.buf_len - overhead;
						/* set length of data area */
	     end;

	disk_data.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 = rdisk_detach;		/* detach entry */
	iocb_ptr -> open = rdisk_open;		/* open entry */
	iocb_ptr -> iocb.control = rdisk_control;	/* control entry */
	iocb_ptr -> modes = rdisk_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 */

/* add this atttachment to the array */
	if found_dev_att
	     then att_dev_idx = pri_iocb_ptr -> attach_data_ptr -> att_dev_idx;

	     else do att_dev_idx = 1 to hbound (attachments.array, 1)
		     while (attachments.array (att_dev_idx).device_att ^= "");
		     end;
	if att_dev_idx > attachments.number_used then attachments.number_used = att_dev_idx;
	if sv_num = -1
	     then					/* user attaching entire device */
		att_sv_idx = 1;
	     else do att_sv_idx = 1 to 3 while (attachments.array (att_dev_idx).sv (att_sv_idx).this_iocbp ^= null ());
		     end;
	if ^(found_dev_att) then attachments.array (att_dev_idx).device_att = addr (rcp_data) -> disk_info.device_name;
	attachments.array (att_dev_idx).sv (att_sv_idx).this_iocbp = iocb_ptr -> actual_iocb_ptr;
						/* the real iocb ptr */
	attachments.array (att_dev_idx).sv (att_sv_idx).this_sv = sv_num;
	attachments.number_attached = attachments.number_attached + 1;
exit:
	a_code = code;				/* return the code */
	return;					/* bye-bye */

parse_attach_options:
     proc;

/* This internal proc sets up the attach_data if this is a subvolume attach */
/* then it will copy the "buddy" disk_data and fill in the new values for   */
/* the attach options. */

dcl  1 at_opt,
       2 sze		       fixed bin (35),
       (
       2 err_sw,
       2 write_sw,
       2 compare_sw,
       2 raw_sw,
       2 alt_sw,
       2 label_sw,
       2 sys_sw
       )			       bit (1) unal,
       2 pack_id		       char (32),
       2 dev_type		       fixed bin,
       2 is_sv		       bit (1),
       2 sv_num		       fixed bin;

dcl  (dv, sv)		       fixed bin;
	at_opt.err_sw = a_err_sw;			/* fill in print errors flag */
	at_opt.write_sw, at_opt.sys_sw, at_opt.compare_sw = "0"b;
						/* initialize switches */
	at_opt.pack_id = " ";			/* clear pack id */
	at_opt.sze = 0;				/* reset size field */
	drive = NOT_SET;				/* init drive field */
	drive_name = "";				/* no specific drive specified */
	model_number = 0;

	at_opt.is_sv = "0"b;			/* default to no subvolume */
	at_opt.sv_num = -1;				/* -1 indcates not sv */
	num_opts = hbound (options, 1);		/* how many descrip. elements? */

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

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

	if dev_id = "m400" then dev_id = "d400";	/* For MR7.0 only */
	else if dev_id = "m451" then dev_id = "d451";	/* For MR7.0 only */

	at_opt.dev_type = 0;			/* clear device type indicator */
	do i = 1 to maxdevt while (at_opt.dev_type = 0);	/*  look up dev. name in dev. char. table */
	     if dev_id = device_names (i) then at_opt.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 at_opt.write_sw = "1"b;
						/* if -write set write mode switch */
	     else if options (i) = "-size"
		then do;				/* if -size, try to set size */
		     if i >= num_opts then call att_err (error_table_$noarg);
						/* if no size value, complain */
		     i = i + 1;			/* set for next option element */
		     at_opt.sze = cv_dec_check_ ((options (i)), code);
						/* pick up size value */
		     if code ^= 0 then call att_err (error_table_$bad_conversion);
						/* if not number, complain */
		     if at_opt.sze <= 0
			then call error (error_table_$bad_arg, "Value of size option must be positive.");
		end;

	     else if options (i) = "-system" | options (i) = "-sys" | options (i) = "-priv"
						/* obsolete */
		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 at_opt.sys_sw = "1"b;
						/* if execute, then priv. process */
			end;
		     if ^at_opt.sys_sw then call att_err (error_table_$user_not_found);
						/* User does not have correct access to rcp_sys_ gate. */
		end;

	     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);
		     call check_dev (drive_name);
		     if code ^= 0 then call att_err (code);

		end;

	     else if options (i) = "-model"
		then do;				/* -model model-number */
		     if i >= num_opts then call att_err (error_table_$noarg);
		     i = i + 1;
		     model_number = cv_dec_check_ ((options (i)), code);
		     if code ^= 0 then call att_err (error_table_$bad_conversion);
		     at_opt.dev_type = 0;
		     do j = 1 to hbound (MODEL, 1) while (at_opt.dev_type = 0);
			if model_number = MODEL (j) then at_opt.dev_type = MODELX (j);
			end;
		     if at_opt.dev_type = 0 then call att_err (error_table_$bad_arg);
		     model_number = MODELN (at_opt.dev_type);
		end;

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

	     end;

	found_dev_att = "0"b;

	if drive_name ^= ""
	     then do;
		do dv = 1 to attachments.number_used while (^found_dev_att);
		     if attachments.device_att (dv) = substr (drive_name, 1, 7)
			then do;
			     if ^found_dev_att
				then do;
				     found_dev_att = "1"b;

				     if at_opt.sv_num = -1 then call att_err (error_table_$resource_assigned);

				     do sv = 1 to 3;
					if attachments.array (dv).this_iocbp (sv) ^= null
					     then do;
						if attachments.array (dv).this_sv (sv) = -1
						     | at_opt.sv_num = attachments.array (dv).this_sv (sv)
						     then call att_err (error_table_$resource_assigned);
						pri_iocb_ptr = attachments.array (dv).this_iocbp (sv);
					     end;
					end;
				end;
			end;
		     end;
	     end;

	if found_dev_att then disk_data = pri_iocb_ptr -> attach_data_ptr -> disk_data;
	disk_data.attach_data = at_opt, by name;
	return;

check_dev:
     proc (at_dev);

/* Internal procedure for checking the device name format on attach */

dcl  at_dev		       char (8);
dcl  at_dev_len		       fixed bin;
dcl  s_code		       fixed bin (35);
	at_dev_len = length (rtrim (at_dev));
	if at_dev_len < 7 then goto invalid_device;

	if substr (at_dev, 1, 3) ^= "dsk" | substr (at_dev, 5, 1) ^= "_" then goto invalid_device;

	s_code = verify (substr (at_dev, 6, 2), "0123456789");
	if s_code ^= 0 then goto invalid_device;

	if at_dev_len = 8
	     then do;
		s_code = verify (substr (at_dev, 8, 1), valid_sv_string);
		if s_code ^= 0 then goto invalid_device;
		at_opt.is_sv = "1"b;
		at_opt.sv_num = (search (valid_sv_string, substr (at_dev, 8, 1))) - 1;
	     end;
	     else do;
		at_opt.is_sv = "0"b;
		at_opt.sv_num = -1;
	     end;
	code = 0;
	return;

invalid_device:
	code = error_table_$invalid_device;
     end check_dev;

     end parse_attach_options;

/*  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;
	if err_sw then call sub_err_ (c_code, "rdisk_", "c", null, retval, "^a", iocb_ptr -> iocb.name);
	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  */

/*  Start of OPEN module  */

rdisk_open:
     entry (a_iocb_ptr, a_mode, a_ext, a_code);

/*
   *           The following opening modes are supported:


   *		stream_input
   *		stream_output
   *		stream_input_output
   *                sequential_input
   *                sequential_output
   *                sequential_update
   *                direct_input
   *                direct_update


   *           Note that if the opening mode is of the output  or  update  type,
   *      the  attach  description  must  include the  -write  control  argument
   *      so  that  the operator  will not  press  the PROTECT button  when  the
   pack is mounted.
*/

dcl  a_mode		       fixed bin;		/* parameter:  open mode  */
dcl  a_ext		       bit (1) aligned;	/* parameter:  extend bit */

	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 = Stream_input
	     then do;
		open_descrip.length = 12;
		open_descrip.descrip = "stream_input";
		real_iocb_ptr -> position = rdisk_position;
		real_iocb_ptr -> get_chars = rdisk_read;
		next_key = bounds.low;
		fill = "101101101"b;		/* Should never be used. */
	     end;

	else if mode = Stream_output
	     then do;
		if ^write_sw
		     then call error (error_table_$incompatible_attach, "stream_output requires -write control arg.");
						/* complain if not attached for write */
		open_descrip.length = 13;
		open_descrip.descrip = "stream_output";
		real_iocb_ptr -> position = rdisk_position;
		real_iocb_ptr -> put_chars = rdisk_write;
		next_key = bounds.low;
		fill = "101101101"b;		/* Should never be used. */
	     end;

	else if mode = Stream_input_output
	     then do;
		if ^write_sw
		     then call error (error_table_$incompatible_attach,
			     "stream_input_output requires -write control arg.");
						/* complain if not attached for write */
		open_descrip.length = 19;
		open_descrip.descrip = "stream_input_output";
		real_iocb_ptr -> position = rdisk_position;
		real_iocb_ptr -> get_chars = rdisk_read;
		real_iocb_ptr -> put_chars = rdisk_write;
		next_key = bounds.low;
		fill = "101101101"b;		/* Should never be used. */
	     end;

	else if mode = Sequential_input
	     then do;
		open_descrip.length = 16;
		open_descrip.descrip = "sequential_input";
		real_iocb_ptr -> position = rdisk_position;
		real_iocb_ptr -> read_record = rdisk_read;
		next_key = bounds.low;
		fill = "101101101"b;		/* Should never be used. */
	     end;

	else if mode = Sequential_output
	     then do;
		if ^write_sw
		     then call error (error_table_$incompatible_attach,
			     "sequential_output requires -write control arg.");
						/* complain if not attached for write */
		open_descrip.length = 17;
		open_descrip.descrip = "sequential_output";
		real_iocb_ptr -> write_record = rdisk_write;
		next_key = bounds.low;
		fill = "000100000"b;		/* ASCII space fill last sector when write. */
	     end;

	else if mode = Sequential_update
	     then do;
		if ^write_sw
		     then call error (error_table_$incompatible_attach,
			     "sequential_update requires -write control arg.");
						/* complain if not attached for write */
		open_descrip.length = 17;
		open_descrip.descrip = "sequential_update";
		real_iocb_ptr -> position = rdisk_position;
		real_iocb_ptr -> read_record = rdisk_read;
		real_iocb_ptr -> rewrite_record = rdisk_rewrite;
		next_key = bounds.low;
		fill = "000100000"b;		/* ASCII space 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 = rdisk_read;
		real_iocb_ptr -> seek_key = rdisk_seek; /* next_key remains NULL */
		fill = "110110110"b;		/* Should never be used. */
	     end;

	else 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 = rdisk_read;
		real_iocb_ptr -> rewrite_record = rdisk_rewrite;
		real_iocb_ptr -> seek_key = rdisk_seek; /* next_key remains NULL */
		fill = "000000000"b;		/* Zero fill last sector when write. */
	     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;


	if a_ext then call error (error_table_$action_not_performed, "Extension attempt -- not valid for disk.");
						/* extension is meaningless for rdisk_ */


	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 = rdisk_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  */
/*  */
/*  Start of SEEK module  */

rdisk_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  */
/*  */
/* Start of POSITION module */

rdisk_position:
     entry (a_iocb_ptr, a_type, a_quantity, a_code);

/*
   *	Position Operation
   *
   *           This operation is supported for  only  the  sequential and stream modes
   *	opening modes.  In the stream opening modes only position mtype 2 is
   supported. The type and quanity values are
   *      interpreted as follows:
   *           _t_y_p_e  _q_u_a_n_t_i_t_y  _a_c_t_i_o_n______________________________________
   *
   *            -1    --       position to the beginning of the file.
   *            +1    --       position to the end of the file.
   *             0    n        skip  n  sectors (forward if n > 0; backward
   *                               if n < 0).
   *             2    n        position to sector n.
   *
   Abbreviations used in the following table are:
   b.l     =  bounds.low = sector address of first sector user can write in.
   b.h     = bounds.high = sector address of last  sector user can write in.
   R(a,b)  = range from a to b inclusive, i.e.,  ( a <= variable <= b )
   nk      = next_key
   qty     = quantity, i.e., the input parameter called quantity in thee above table.

   <--------  If all of these conditions are satisfied  ----->        <-- then do this ---->
   absolute					set
   value of					next_key
   type   next_key  quantity  quantity            nk+qty              equal to  other action
   ____	________	________	_____________	____________	_________	____________

   -1	--	--	--		--		b.l	--

   +1	--	--	--		--		END	--

   2	--	< b.l	--		--		b.l	error

   2	--	R(b.l,b.h)  --		--		quantity	--

   2	--	> b.h	--		--		END	error

   0	NULL	--	--		--		--	error

   0	R(b.l,b.h)  --	--		R(b.l,b.h)	nk+qty	--

   0	R(b.l,b.h)  --	--		< b.l		b.l	error

   0	R(b.l,b.h)  --	--		> b.h		END	error

   0	END	<= 0	<=(b.h-b.l+1)	--		b.h-qty+1	--

   0	END	> 0	--		--		END	error

   0	END	< 0	>(b.h-b.l+1)	--		b.l	error

   For sequential_update, if no errors occur, current_key = new value of next_key
   */
/*  */

dcl  a_type		       fixed bin;		/* type of positioning requested */
dcl  type			       fixed bin;
dcl  a_quantity		       fixed bin (21);	/* how far to move the position */
dcl  quantity		       fixed bin;
dcl  desired_key		       fixed bin;		/* possible resulting value */

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


	if mode = Direct_update | mode = Direct_input
	     then call error (error_table_$no_operation,
		     "Position operation valid only for sequential or stream openings.");

	type = a_type;

	quantity = a_quantity;

	if (type < -1) | (2 < type)
	     then call error (error_table_$no_operation, "Only legal values for type are -1, 0, +1, and +2");

	if mode = Stream_input | mode = Stream_output | mode = Stream_input_output
	     then do;
		if mod (quantity, sect_size * 4) ^= 0
		     then do;
			next_key = NULL;
			call error (error_table_$no_record, "Byte offset specified not at begining of sector");
		     end;

		quantity = divide (quantity, sect_size * 4, 17, 0);
	     end;

	if type = -1
	     then do;				/* position to beginning of the file */
		next_key = bounds.low;
	     end;

	else if type = +1
	     then do;				/* position to end of the file */
		next_key = END;
	     end;					/* type = 2 is absolute positioning */

	else if (type = 2) & (quantity < bounds.low)
	     then do;
		call error (error_table_$end_of_info, "quantity is before first available sector");
		next_key = bounds.low;
	     end;

	else if (type = 2) & (bounds.low <= quantity) & (quantity <= bounds.high)
	     then do;
		next_key = quantity;
	     end;

	else if (type = 2) & (quantity > bounds.high)
	     then do;
		call error (error_table_$end_of_info, "quantity is after last available sector");
		next_key = END;
	     end;

/* type = 0 is relative positioning */
	else if (type = 0) & (next_key = NULL)
	     then call error (error_table_$no_current_record, "Present position is undefined.");

	else if (type = 0) & (next_key ^= NULL) & (next_key ^= END)
	     then do;
		desired_key = next_key + quantity;
		if (bounds.low <= desired_key) & (desired_key <= bounds.high)
		     then do;
			next_key = desired_key;
		     end;

		else if (desired_key < bounds.low)
		     then do;
			call error (error_table_$end_of_info,
			     "Present position plus quantity is before start of the file.");
			next_key = bounds.low;
		     end;

		else if (desired_key > bounds.high)
		     then do;
			call error (error_table_$end_of_info,
			     "Present position plus quantity is past end of the file.");
			next_key = END;
		     end;
	     end;


/* May be OK to back up from the end of the file */

	else if (type = 0) & (next_key = END) & (quantity <= 0) & (abs (quantity) <= (bounds.high - bounds.low + 1))
	     then do;
		next_key = bounds.high + quantity;	/* "+ quantity" (not minus) because quantity is negative, or zero  */
	     end;

	else if (type = 0) & (next_key = END) & (quantity > 0)
	     then call error (error_table_$end_of_info, "Were at file end; quantity attempted to move forward.");
						/* next_key still = END */


	else if (type = 0) & (next_key = END) & (quantity < 0) & (abs (quantity) > (bounds.high - bounds.low + 1))
	     then do;
		call error (error_table_$end_of_info, "Were at file end; quantity would put you before file.");
		next_key = bounds.low;
	     end;

	else call error (error_table_$no_operation, "Should never get to this point.");


	if mode = Sequential_update then current_key = next_key;
	a_code = 0;				/* If we get here, there were no errors. */
	return;


/* End of POSITION module */
/*  */
/*  Start of READ and WRITE modules  */

rdisk_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 mode = Sequential_output | mode = Stream_output
	     then					/* read OK for all other modes */
		call error (error_table_$invalid_read, "read not supported for sqo or so.");
	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;
		if mode = Sequential_input | mode = Sequential_update
		     then do;
			current_key = NULL;
			call error (error_table_$end_of_info,
			     "Attempted to read (sqi, squ) past end of available area.");
		     end;
		     else do;			/*  mode = either direct_input or direct_update */
			next_key = NULL;
			current_key = NULL;
			call error (error_table_$device_end,
			     "Attempted to read (di, du) past end of avilable area.");
		     end;
	     end;
	io_command = "read";			/* set switch for read */


	if sze ^= 0
	     then rec_len = min (sze, a_ubuf_len);	/* set appropriate record length */
	     else 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 */

rdisk_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 mode = Sequential_update | mode = Direct_update
	     then ;
	     else call error (error_table_$invalid_write, "rewrite valid only for update.");

	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 */
	go to read_write_common;

rdisk_write:
     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 ASCII spaces.  A code of  0  is  returned  in  this  case.
   *      This   operation   is   supported  for  only  the
   *      sequential_output  opening  mode.   A  series  of  writes  will  write
   *      successive records.
*/


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

	if mode = Sequential_output | mode = Stream_output | mode = Stream_input_output
	     then ;
	     else call error (error_table_$invalid_write, "write supported only for sqo, so, and sio.");

	if next_key = END
	     then do;
		current_key = NULL;
		call error (error_table_$device_end, "Already at end of the file.");
	     end;

	else if next_key = NULL then call error (error_table_$no_record, "Next record designator was NULL.");

	io_command = "write";
	rec_len = a_rec_len;			/* set output record length */
	key = next_key;				/* set working key */
	go to read_write_common;

read_write_common:					/*
   *           For the sequential_input and sequential_update opening modes,  if
   *      an attempt is made to read beyond the end of the user-accessible area,
   *      the   code   error_table_$end_of_info  is  returned  to  the   calling
   *      program.   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  the
   *      write  and  rewrite  operations,  unless overridden by a -size control
   *      argument in the attach description, or by a setsize control order.
*/
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 = "write") | (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.");

	tot_rec_len = 0;				/* init total records counter */
	ubuf_ptr = a_ubuf_ptr;			/* grab pointer to user buffer */
	cont_sw = "0"b;				/* reset control switch if set */
	track_indicators = "00"b;			/* reset ti bits if set */
	if rec_len > 4 * (floor ((max_buff_size - overhead) / sect_size) * sect_size)
	     then do;				/* if record longer than maximum ioi_ buffer size */

		if buf_len < max_buff_size
		     then do;			/* if current ioi_ buffer len. < max. */
			call ioi_$workspace (devx, buf_ptr, max_buff_size, code);
						/* grow it to max size */
			if code ^= 0 then call io_err ("1"b);
						/* no luck */
			buf_len = max_buff_size;	/* set current length */
			data_len = buf_len - overhead;/* set data area length */
		     end;

		block_len = ceil (ceil (data_len / 4) / sect_size) * sect_size;
						/* set I/O block size */
		block_ptr = ubuf_ptr;		/* initialize block pointer */
		data_left = rec_len;		/* initialize amount of data left to xmit */

		do while (data_left > 0);		/*  perform the I/O one block at a time */
		     call do_io;			/* do the  I/O */
		     block_ptr = addrel (block_ptr, block_len);
						/* set pointer for next block */
		     tot_rec_len = tot_rec_len + rec_len;
						/* remember total records */
		     data_left = data_left - block_len * 4;
						/* decrement data left to xmit */
		     key = key + fixed (block_len / sect_size, 21);
						/* increment the working key */
		     end;

	     end;

	     else do;				/*   record will fit within max-sized ioi_ buffer */

		if rec_len > 4 * floor (data_len / sect_size) * sect_size
		     then do;			/*  if record longer than current ioi_ buffer size */

			data_len = max (1024 - overhead, ceil (ceil (rec_len / 4) / sect_size) * sect_size);
			buf_len = data_len + overhead;/* tell ioi_ how much space we need */
			call ioi_$workspace (devx, buf_ptr, buf_len, code);
						/* grow the buffer */
			if code ^= 0 then call io_err ("1"b);
						/* can't win all the time */

		     end;

		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  (only one block this time) */

	     end;


io_succeeded:					/* 			PATH 1 */
	if io_command = "read"
	     then do;

		current_key = next_key;
		if tot_rec_len = 0
		     then a_rec_len = rec_len;	/* Send back length of data actually read. */
		     else a_rec_len = tot_rec_len;	/* ditto */

/* 			PATH 1a */

		if potential_next_sector < bounds.high + 1
		     then do;			/* Record will _n_o_t reach end of available area. */

/* 			PATH 1a1 */

			if mode = Direct_input | mode = Direct_update
			     then next_key = NULL;

/* 			PATH 1a2 */

			     else next_key = next_key + sectors_for_record;
		     end;

/* 			PATH 1b */

		     else do;			/* potential_next_sector = bounds.high + 1 */
						/* Record _w_i_l_l reach end of available area. */

/* 			PATH 1b1 */

			if mode = Direct_input | mode = Direct_update
			     then next_key = NULL;

/* 			PATH 1b2 */

			     else next_key = END;

		     end;

	     end;


/* 			PATH 2 */

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

/* 			PATH 2a */

		if mode = Sequential_update
		     then				/* 			PATH 2a1 */
			if potential_next_sector < bounds.high + 1
			     then			/* Record will _n_o_t reach end of available area. */
				next_key = current_key + sectors_for_record;

/* 			PATH 2a2 */

			     else next_key = END;	/* potential_next_sector = bounds.high + 1 */
						/* Record _w_i_l_l reach end of available area. */

/* 			PATH 2b */

		     else next_key = NULL;		/* mode = direct_update */

	     end;

/* 			PATH 3 */

	else if io_command = "write"
	     then do;

		current_key = NULL;

/* 			PATH 3a */

		if potential_next_sector < bounds.high + 1
		     then				/* Record will _n_o_t reach end of available area. */
			next_key = next_key + sectors_for_record;

/* 			PATH 3b */

		     else next_key = END;		/* potential_next_sector = bounds.high + 1 */
						/* Record _w_i_l_l reach end of available area. */

	     end;

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

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

/*  */

/*  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;

/*  */

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

do_io:
     proc;

dcl  (true_len, data_read)	       fixed bin (35);	/* internal data  manipulation variables */
dcl  sector_offset		       fixed bin;		/* used for subvolumes */
	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" & ^cont_sw
	     then do;				/* if an output command and not  format */

		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_NORMAL_SEEK;
	else if key <= last_alt_sect_num (dev_type)	/* in the alternate region */
	     then goto BUILD_ALT_SEEK (device_group);
	else goto BUILD_TANDD_SEEK (device_group);	/* must be T&D region */


BUILD_TANDD_SEEK (1):				/* T&D region on MSU04XX device */
	idcw.command = SPECIAL_SEEK;			/* seek cmd = spiecial seek */

BUILD_ALT_SEEK (1):					/* Alternate track region on MSU04XX device */
BUILD_NORMAL_SEEK:
	idcw.command = seek_command (dev_type);
	unspec (seek) = "0"b;
	seek.block_count_limit = count_limit_fixed;
	seek.ti = track_indicators;
	if is_sv
	     then do;				/* convert the key to real sector */
		sector_offset = mod (key, sect_per_cyl (dev_type));
		seek.sector =
		     ((key - sector_offset) * number_of_sv (dev_type)) + (sv_num * sect_per_cyl (dev_type))
		     + sector_offset;
	     end;
	     else seek.sector = key;
	unspec (seek_data) = unspec (seek);
	goto SEEK_BUILT;


BUILD_ALT_SEEK (2):					/* Alternate track region on MSU0500/1 device */
BUILD_TANDD_SEEK (2):				/* T&D 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_ALT_SEEK (3):					/* Alternate track region on MSU0509 device */
BUILD_TANDD_SEEK (3):				/* T&D region on MSU0509 device */
	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 cont_sw
	     then do;				/* if format trk or rd trk header */
		idcw = control_idcw_template;
		idcw.command = control_command;
	     end;
	else if (io_command = "read") then idcw = read_idcw_template;
						/* if read, put in canned read value */
	else if compare_sw then idcw = write_and_compare_idcw_template;
						/*  put in compare comd. if in that mode */
	else idcw = write_idcw_template;		/* put in canned write value */
	idcw.device = bit (drive);			/*  fill in drive number */

	dcw_address = bin (rel (addr (data)));		/* Beginning of data */
	rw_length = block_len;			/* Length of data */
	do dcwx = 1 by 1 while (rw_length > 0);		/* Build each DCW */
	     dcwp = addr (rw_dcw (dcwx));		/* point to next dcw */
	     dcw = read_write_dcw_template;		/* IOTP */
	     dcw.address = bit (bin (dcw_address, 18), 18);
	     if rw_length >= MAX_DCW_TALLY
		then dcw.tally = bit (bin (MAX_DCW_TALLY, 12), 12);
		else dcw.tally = bit (bin (rw_length, 12), 12);
	     dcw_address = dcw_address + MAX_DCW_TALLY;
	     rw_length = rw_length - MAX_DCW_TALLY;
	     end;

	dcw.type = IOTD;

	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 loud_retry;	/* 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;


			     if (mode = Sequential_input) | (mode = Sequential_update)
				then code = error_table_$end_of_info;
				else code = error_table_$device_end;
						/* all other modes */


			     call io_err ("0"b);	/* tell user */
			end;
		     else if ((status.sub & TI_MASK) ^= "00"b3) & cont_sw & (io_command = "read") then ;
		     else call perm_err;		/* any other EOF is bad news */

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

	     end;

	if (io_command = "read") & ^cont_sw
	     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;

	if (io_command = "read") & cont_sw
	     then substr (info_block, 1, 4 * (block_len - fixed (status.residue))) =
		     substr (data, 1, 4 * (block_len - fixed (status.residue)));
						/* if rd trk header command */

     end do_io;

/*  */

/*  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;

/*  */

/*  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 loud_retry;			/* 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;

/*  */

/*  Internal procedure to handle ATTENTION status (non-STANDBY)  */

loud_retry:
     proc;

/*  This really should go to the operator's console.  */

	call command_query_ (addr (query_info), answer, "rdisk_",
	     "Your disk drive (No. ^d) needs attention.  Please have the operator
check it out and reply appropriately _a_f_t_e_r the device has been checked.

Do you wish to retry?", drive);

	if answer = "yes"
	     then call retry;
	     else call perm_err;			/* your wish is my command */

     end loud_retry;

/*  */


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

perm_err:
     proc;

/*  This procedure obtains the detailed device status, and dumps all available
   status information to the user terminal.  It would be nice if this info could
   be  put out on the operator's console, but there is currently no way for
   a normal user's process to put it there.  */

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

	call ioi_$get_detailed_status (devx, found, buffer.control_info.rsr_data, code);

	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 sub_err_ (0, "rdisk_", "c", null, retval,
	     "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 (string (status), 1, 36),
	     substr (string (status), 37, 36), idcw, dcw);

	if found then call ioa_$ioa_stream ("error_output", "Detailed Device Status: ^( ^2.4b^) (hex)", based_rsr_data);

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

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

     end perm_err;

/*  */

/*  Start of CONTROL module  */

rdisk_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.
   *
   *		changepack          causes  the  current  pack  to   be
   *				dismounted  and  another pack to be
   *				mounted in its place.  The info_ptr
   *				should point to a varying character
   *				string (maximum of  32  characters)
   *				containing  the  identifier  of the
   *				pack  to be mounted.
   *
   *		getbounds           causes  the  lowest   and   highest
   *				sector  numbers  accessible  by the
   *				caller under the current  modes  to
   *				be  returned.   The info_ptr should
   *				point  to  a  structure  like   the
   *				following:
   *
   *				dcl 1 bounds,
   *				      2  low fixed bin (35),
   *				      2  high fixed bin (35);
   *
   *		setsize             causes the value of the record size
   *				override setting to be reset.   The
   *				info_ptr  should  point  to a fixed
   *				bin(35) quantity containing the new
   *				override value.
   *
   *		device_info         causes  information  pertaining  to
   *				the  attached  disk  device  to  be
   *				returned to the user.  The info_ptr
   *				should point to a structure of  the
   *				following form:
   *
   *				dcl 1 device_info_table aligned,
   *				    2 dev_type char (4),
   *				    2 device_name char (8),
   *				    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);
   *
   *				where:
   *
   *				1. subsystem_name  is the  name  of
   *				   the  Disk subsystem in use (i.e.
   *				   "D191").
   *
   *				2. device_name  is the  name of the
   *				   disk   device   in   use   (i.e.
   *				   "disk_04").
   *
   *				3. sect_per_dev    is   the   total
   *				   number of non-T&D sectors on the
   *				   disk pack.
   *
   *				4. cyl_per_dev  is the total number
   *				   of non-T&D cylinders on the disk
   *				   pack.
   *
   *				5. sect_per_cyl  is the  number  of
   *				   data  sectors   on each cylinder
   *				   of a disk pack.
   *
   *				6. sect_per_track  is the number of
   *				   data sectors on each track.
   *
   *				7. num_label_sect  is the number of
   *				   data  sectors  to  reserve   for
   *				   label information.
   *
   *				8. num_alt_sect  is the  number  of
   *				   data   sectors  to  reserve  for
   *				   alternate  track area.
   *
   *				9. sect_size  is the number  of  36
   *				   bit  words  in each data sector.
   *
   *		format_trk          causes a format track command to be
   *				issued  to  the  track   that   was
   *				indicated  by a preceeding seek_key
   *				operation.   The  info_ptr   should
   *				point  to a user supplied structure
   *				of the following form:
   *
   *				dcl 1 format_trk_info aligned,
   *				   (2 hz bit (2),
   *				    2 ti bit (2),
   *				    2 adcyl fixed bin (16),
   *				    2 adhd fixed bin (16)) unal;
   *
   *				where:
   *
   *				1. hz is a bit  pattern  indicating
   *				   the  state  of the header bypass
   *				   switch. The hz bits are  defined
   *				   as follows:
   *
   *				      h z   bit pattern meaning
   *				      0 0   format  home   address
   *				            and all data records
   *				      0 1   verify  home   address
   *				            and record one, format
   *				            home  address  and all
   *				            data records
   *				      1 0   skip   home   address,
   *				            format     all    data
   *				            records
   *				      1 1   verify  home   address
   *				            and  data  record one,
   *				            skip home address  and
   *				            format    all     data
   *				            records
   *
   *				2. ti is a bit  pattern  indicating
   *				   the state of the track indicator
   *				   bits. The ti bits are defined as
   *				   follows:
   *
   *				      t i   bit pattern meaning
   *				      0 0   format trk good
   *				      0 1   format trk alternate
   *				      1 0   format  trk  defective
   *				            with   alternate   trk
   *				            assigned
   *				      1 1   format  trk  defective
   *				            with  no alternate trk
   *				            assigned
   *
   *				3. adcyl and adhd are the alternate
   *				   or defective cylinder  and  head
   *
   *				   numbers  used  when   the  track
   *				   indicator bits  equal  "01"b  or
   *				   "10"b.   These  two  fields  are
   *				   defined as follows:
   *
   *				   If the track indicator bits  are
   *				   set  to  "01"b  (alternate trk),
   *				   then adcyl and adhd   should  be
   *				   equal  to the defective cylinder
   *				   and head number  for  which  the
   *				   alternate    track    is   being
   *				   formatted.
   *
   *				   If the track indicator bits  are
   *				   set  to  "10"b  (defective  with
   *				   alternate assigned), then  adcyl
   *				   and  adhd should be equal to the
   *				   cylinder and head number of  the
   *				   alternate track.
   *
   *		rd_trk_header       causes a read track header  command
   *				to  be issued to the track that was
   *				indicated by a preceeding  seek_key
   *				operation.  The  raw  track  header
   *				information is passed  to the  user
   *				in   a  structure  (pointed  to  by
   *				info_ptr) of the following form:
   *
   *				dcl 1 trk_header_info aligned,
   *				   (2 ha_cyl bit (16),
   *				    2 ha_head bit (16),
   *				    2 pad1 bit (2),
   *				    2 ha_ti bit (2),
   *				    2 pad2 bit (10),
   *				    2 rcd_0_ti bit (2),
   *				    2 rcd_0_cyl bit (16),
   *				    2 rcd_0_head bit (16),
   *				    2 rcd_0_rn bit (8),
   *				    2 pad3 bit (24),
   *				    2 rcd_0_data (8), bit (8),
   *				    2 pad4 bit (4)) unaligned;
   *
   *				where:
   *
   *				1. ha_cyl is  the  cylinder  number
   *				   read   from   the   track   home
   *				   address.
   *
   *				2. ha_head is the head number  read
   *				   from the track home address.
   *
   *				3. ha_ti  is  the  track  indicator
   *				   bits    (defined  above  in  the
   *				   format_trk order)  read from the
   *				   track home address.
   *
   *				4. rcd_0_ti is the track  indicator
   *				   bits  read  from record zero. If
   *				   the ha_ti bits  indicate  "10"b,
   *				   then rcd_0_ti should equal "01"b
   *				   for  alternate track.  If  ha_ti
   *				   indicates "01"b,  then  rcd_0_ti
   *				   should equal "10"b for defective
   *				   track.   Otherwise rcd_0_ti will
   *				   equal ha_ti.
   *
   *				5. rcd_0_cyl and rcd_0_head are the
   *				   cylinder and  head  number  read
   *				   from   record  zero.   If  ha_ti
   *				   indicates "10"b, then  rcd_0_cyl
   *				   and  rcd_0_head  will  equal the
   *				   cylinder and head number of  the
   *				   alternate    track.   If   ha_ti
   *				   indicates "01"b, then  rcd_0_cyl
   *				   and  rcd_0_head will contain the
   *				   cylinder and head number of  the
   *				   defective    track.    Otherwise
   *				   rcd_0_cyl  and  rcd_0_head  will
   *				   equal ha_cyl and ha_head.
   *
   *				6. rcd_0_rn is  the  record  number
   *				   for record zero (normally  equal
   *				   to zero).
   *
   *				7. rcd_0_data  is  the  eight  data
   *				   bytes  in  record  zero  (not  a
   *				   normal  data  record)  and  will
   *				   normally be equal to zero.
   *
   *				8. padn are unused bits which  will
   *				   be returned as "0"b.
*/

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 = "io_call"
	     then do;				/* special order for io_call command */
		call io_call_order;
		a_code = code;
		return;
	     end;
	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 = "changepack") & media_removable (dev_type)
	     then do;				/* process the "changepack" order */
		call rcp_$detach (rcp_id, (RETAIN), errors, "", code);
						/* dismount current pack */
		if code ^= 0 then call error (code, "");/* didn't work too well */
		pack_id = new_pack_id;		/* pick up new pack id. */
		call mount ();			/* mount it */
		if code ^= 0 then call error (code, "");/* it's hard for a little pack to get on a big drive */

		new_length = index (pack_id, " ") - 1;	/* get length of  the new pack id string */
		old_length = index (substr (attach_descrip.descrip, 13), " ") - 1;
						/* and see how long the old one was */
		if new_length = old_length
		     then				/* if the same, just overlay the old one in the att. desc. */
			substr (attach_descrip.descrip, 13, old_length) = substr (pack_id, 1, new_length);
		     else do;			/* otherwise, we have to do some juggling  */
			old_descrip = attach_descrip.descrip;
						/* put the old one in a temp area */
			attach_descrip.descrip = substr (old_descrip, 1, 12) || substr (pack_id, 1, new_length)
						/* and build */
			     || substr (old_descrip, 13 + old_length, attach_descrip.length - old_length - 12);
						/* the new one */
			attach_descrip.length = attach_descrip.length + new_length - old_length;
						/* adjust the length */
		     end;
	     end;					/*  changepack  */

	else 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 = "setsize" then sze = new_size;	/*  The "setsize" order is easy * */

	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 = "format_trk") & device_group = MSU04XX
	     then do;				/* process the "format_trk" order */
		fmdp = addr (buffer.data);		/* set up data pointer */
		key = current_key;			/* convert key to binary */
		if key < sect_per_cyl (dev_type)
		     then cyl = 0;			/* :: */
		     else cyl = divide (key, sect_per_cyl (dev_type), 16, 0);
						/* figure cylinder number */
		i = mod (key, sect_per_cyl (dev_type)); /* save remainder */
		if i <= 0
		     then head = 0;			/* figure out head */
		     else head = divide (i, sect_per_track (dev_type), 16, 0);
		fmt_dta = "0"b;			/* clear out the buffer first */
		fmt_dta.svcyl = bit (cyl);		/* set up seek verif. cyl number */
		fmt_dta.svhd = bit (head);		/* set up seek verif. head number */
		if fmt_info.ti = "01"b | fmt_info.ti = "10"b
		     then do;
			fmt_dta.r0ccyl = bit (fmt_info.alt_def_cyl);
						/* if alt or def trk to be formated */
			fmt_dta.r0chd = bit (fmt_info.alt_def_hd);
						/* use user supplied cyl and head */
			if fmt_info.ti = "10"b
			     then			/* for r0 count field */
				fmt_dta.r0cti = "01"b;
			     else fmt_dta.r0cti = "10"b;
		     end;
		     else do;
			fmt_dta.r0ccyl = bit (cyl);	/* otherwise use the present position */
			fmt_dta.r0chd = bit (head);
			fmt_dta.r0cti = fmt_info.ti;
		     end;
		fmt_dta.hz = fmt_info.hz;		/* copy the header bypass info */
		fmt_dta.ti = fmt_info.ti;		/* copy the ti bits */
		fmt_dta.chk_chr = cksum ();		/* compute cksum char. */
		track_indicators = fmt_info.ti;	/* copy ti bits for seek command */
		control_command = FORMAT_TRK;		/* set up the active command to format trk */
		io_command = "format";		/* make sure not read */
		cont_sw = "1"b;			/* set the control sw */
		block_len = 5;			/* set the data xfer length to 5 words */
		call do_io ();			/* execute the format command sequence */
	     end;

	else if order = "rd_trk_header" & device_group = MSU04XX
	     then do;				/* process the "rd_trk_header" order */
		key = next_key;			/* convert key to binary */
		cont_sw = "1"b;			/* set control switch */
		io_command = "read";		/* set up for read command */
		block_len = 5;			/* set  the data xfer length to 5 words */
		track_indicators = "00"b;		/* reset track_indicators */
		control_command = RD_TRK_HEADER;	/* set the command to 27 (8) */
		call do_io ();			/* execute the read trk header command sequence */
	     end;

	else if order = "read_track_header"		/* New style read track header order for 451s or 500s. */
	     then do;				/* process the "rd_trk_header" order */
		thi_ptr = info_ptr;
		if thi.version ^= thi_version_1	/* wrong version number in structure */
		     then call error (error_table_$unimplemented_version, "");
		info_ptr = addr (thi.msu4xx_info);	/* data is in word after version */
		key = next_key;			/* convert key to binary */
		cont_sw = "1"b;			/* set control switch */
		io_command = "read";		/* set up for read command */
		block_len = FORMAT_DATA_LEN (dev_type); /* set the data xfer length to proper value */
		unspec (info_ptr -> block) = "0"b;
		track_indicators = "00"b;		/* reset track_indicators */
		control_command = RD_TRK_HEADER;	/* set the command to 27 (8) */
		call do_io ();			/* execute the read trk header command sequence */
	     end;

	else if order = "format_track"
	     then do;				/* Format either a 4xx or a 5xx device */
		thi_ptr = info_ptr;
		if thi.version ^= thi_version_1	/* wrong version number */
		     then call error (error_table_$unimplemented_version, "Bad header version.");
		if dev_type > 7 then call error (error_table_$unimplemented_version, "Bad header version.");
		key = current_key;
		track_indicators = bit (thi.msu4xx_info.ti);
		control_command = FORMAT_TRK;
		io_command = "format";
		cont_sw = "1"b;
		block_len = FORMAT_DATA_LEN (dev_type); /* set proper block length */
		addr (data) -> block = addrel (addr (thi), 1) -> block;
		call do_io ();
	     end;

	else if order = "hardware_status" then user_hardware_status = iom_stat;

	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  */

/*  */

/*  Start of MODES module  */

rdisk_modes:
     entry (a_iocb_ptr, a_new_modes, a_old_modes, a_code);

/*
   *	     The modes operation is supported  when  the  I/O  switch  is
   *	attached.   The recognized modes are listed below.  Each mode has
   *	a complement indicated by the character "^" (e.g. "^label")  that
   *	turns the mode off.
   *
   *		label,^label        specifies  that  a   system-defined
   *				number  of sectors at the beginning
   *				of the pack are reserved for a pack
   *				label,   and   that   a    seek_key or position
   *				operation   is  to  treat  any  key
   *				within this area as an invalid key.
   *				(Default is on.)
   *
   *		alttrk,^alttrk      specifies that the  pack  has  been
   *				formatted  with  the  assignment of
   *				alternate   tracks,   so   that   a
   *				system-defined number of sectors at
   *				the  end  of  the pack are reserved
   *				for  an   alternate   track   area.
   *				Therefore,  a seek_key or position operation is
   *				to treat any key within  that  area
   *				as  an  invalid  key.   (Default is
   *				off.)
   *
   *		wrtcmp,^wrtcmp      specifies         that          the
   *				Write-and-Compare
   *				instruction,rather than  the  Write
   *				instruction  will  be  used for the
   *				rewrite_record   operation.    This
   *				causes  all  data written out to be
   *				read back in and  compared  to  the
   *				data  as  it  was  prior  to  being
   *				written.  This mode should be  used
   *				with  discretion,  since it doubles
   *				the data  transfer  time  of  every
   *				write.  (Default is off.)
   *
   *		raw, ^raw           specifies that the entire disk pack
   *		                    is available to the user, including
   *		                    the  T  &  D  cylinder  (the   last
   *		                    cylinder  on  the  disk pack). (The
   *		                    default is off.)
*/

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

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

	if length (a_old_modes) > 0 then a_old_modes = mode_string;
						/* if wanted, pass back old modes */

	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 rdisk_, 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  */

/*  */

/*  Start of CLOSE module  */

rdisk_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 = rdisk_open;		/* set open entry */
	real_iocb_ptr -> detach_iocb = rdisk_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  */
/*  */
/*  Start of DETACH  module  */

rdisk_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 */
	rcp_detachment = "0"b;
	call delete_attach (rcp_detachment);

	if rcp_detachment
	     then do;
		call rcp_$detach (rcp_id, (DEFAULT), errors, "", code);
						/* detach the device */
		call ipc_$delete_ev_chn (ev_chan, code);/* get rid of event channel */
	     end;

	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;

delete_attach:
     proc (detach_rcp);


/* Internal proc to delete this attachment from the array */
dcl  detach_rcp		       bit (1);
dcl  sv_att_idx		       fixed bin;
dcl  count_att		       fixed bin;
	count_att = 0;
	if attachments_ptr = null () then detach_rcp = "1"b;
						/* some this is wrong let rcp complain it may know */
	if attachments.array (att_dev_idx).sv (1).this_sv = -1
						/* attached as one device can only be one attachment */
	     then count_att = 1;
	     else do sv_att_idx = 1 to 3;		/* count the number of attachments for this device */
		     if attachments.array (att_dev_idx).sv (sv_att_idx).this_iocbp ^= null ()
			then count_att = count_att + 1;
		     end;
	attachments.array (att_dev_idx).sv (att_sv_idx).this_iocbp = null ();
	if count_att = 1
	     then do;
		detach_rcp = "1"b;
		attachments.array (att_dev_idx).device_att = "";
	     end;
	attachments.number_attached = attachments.number_attached - 1;
	if attachments.number_attached = 0
	     then do;				/* free attachment array */
		free attachments in (system_area);
		attachments_ptr = null ();
	     end;
	return;
     end delete_attach;


/*  End of DETACH module  */
/*  */
/*  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 (32) varying;	/*  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 ^= "rdisk_"
	     then do;
		setup_error_msg = "Not attached by rdisk_ 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;					/*  */

/*  Internal ERROR Procedure  */

error:
     proc (cd, err_msg);

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

	if disk_ptr ^= null
	     then					/* if we have a work seg, we can check print-error switch */
		if err_sw
		     then call sub_err_ (cd, "rdisk_", "c", null, retval, "^a  ^a", iocb_ptr -> iocb.name, err_msg);
						/* print if desired */
		     else ;
	     else call sub_err_ (cd, "rdisk_", "c", null, retval, "^a  ^a", iocb_ptr -> iocb.name, err_msg);
						/* can't check, just give it to him */

	code = cd;				/* set code */

	go to exit;				/* and exit, stage right */

     end error;

/*  */

/*  Internal PACK MOUNT procedure  */

mount:
     proc;
dcl  cleanup		       condition;

	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;

/*  */

/*  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;					/*  */

/*  Internal CHECKSUM procedure  */


cksum:
     proc returns (bit (6));

/* routine to compute exclusive or check char */

dcl  ckchar		       bit (6);		/* working storage */
dcl  fmtsum		       (30) bit (6) based (fmdp);
						/* format data as 6 bit char */
	ckchar = "0"b;				/* initialize working storage */
	do i = 1 to 30;				/* compute check char */
	     ckchar = bool (ckchar, fmtsum (i), "0110"b);
	     end;
	return (ckchar);				/* return computed check character */
     end cksum;

/*  */
/* Internal procedure to handle the io_call order */

io_call_order:
     proc;

dcl  changepack		       char (32) var;
dcl  1 getbounds		       aligned,
       2 low		       fixed bin (35),
       2 high		       fixed bin (35);
dcl  setsize		       fixed bin (35);
dcl  1 device_info_table	       aligned,
       2 dev_type		       char (4),
       2 device_name	       char (8),
       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 track_header_data	       like thi;

%include io_call_info;

	io_call_infop = a_info_ptr;
	if io_call_info.order_name = "setsize"
	     then do;
		if io_call_info.nargs ^> 0
		     then do;
			call io_call_info.error (error_table_$noarg, io_call_info.caller_name, "New size.");
			return;
		     end;
		setsize = cv_dec_check_ ((io_call_info.args (1)), code);
		if code ^= 0
		     then do;
			call io_call_info
			     .error (0, io_call_info.caller_name, "Invalid size: ^a.", io_call_info.args (1));
			code = 0;
			return;
		     end;
		call iox_$control (iocb_ptr, "setsize", addr (setsize), code);
		return;
	     end;
	else if io_call_info.order_name = "changepack"
	     then do;
		if io_call_info.nargs ^> 0
		     then do;
			call io_call_info.error (error_table_$noarg, io_call_info.caller_name, "New pack name.");
			return;
		     end;
		changepack = io_call_info.args (1);
		call iox_$control (iocb_ptr, "changepack", addr (changepack), code);
		return;
	     end;
	else if io_call_info.order_name = "getbounds"
	     then do;
		call iox_$control (iocb_ptr, "getbounds", addr (getbounds), code);
		if code = 0
		     then do;
			call io_call_info
			     .
			     report ("^a: Sectors available are ^d:^d", io_call_info.caller_name, getbounds.low,
			     getbounds.high);
		     end;
		return;
	     end;
	else if io_call_info.order_name = "device_info"
	     then do;
		call iox_$control (iocb_ptr, "device_info", addr (device_info_table), code);
		if code = 0
		     then do;
			call io_call_info
			     .
			     report ("Device Characteristics:^/^/device type:^-^-^a^/device name:^-^-^a",
			     device_info_table.dev_type, device_info_table.device_name);
			call io_call_info
			     .
			     report ("sectors per device:^-^-^d^/cylinders per device:^-^d",
			     device_info_table.sect_per_dev, device_info_table.cyl_per_dev);
			call io_call_info
			     .
			     report ("sectors per cylinder:^-^d^/sectors per track:^-^-^d",
			     device_info_table.sect_per_cyl, device_info_table.sect_per_track);
			call io_call_info
			     .
			     report ("number of label sectors:^-^d^/number of alternate sectors:^-^d",
			     device_info_table.num_label_sect, device_info_table.num_alt_sect);
			call io_call_info.report ("sector size (words):^-^d", device_info_table.sect_size);
		     end;
		return;
	     end;

	else if io_call_info.order_name = "read_track_header"
	     then do;
		track_header_data.version = thi_version_1;
		call iox_$control (iocb_ptr, "read_track_header", addr (track_header_data), code);
		if code = 0
		     then if io_call_info.nargs > 0
			     then if io_call_info.args (1) = "-hex"
				     then call print_track_header_info (addr (track_header_data),
					     io_call_info.report, "1"b);
				     else call print_track_header_info (addr (track_header_data),
					     io_call_info.report, "0"b);
			     else call print_track_header_info (addr (track_header_data), io_call_info.report, "0"b)
				     ;
		return;
	     end;
	else if io_call_info.order_name = "format_trk" | io_call_info.order_name = "rd_trk_header"
	     | io_call_info.order_name = "read_track_header"
	     then do;
		call io_call_info
		     .
		     error (0, io_call_info.caller_name, "The ^a control order is not supported by io_call",
		     io_call_info.order_name);
		return;
	     end;

	else code = error_table_$no_operation;
	return;

     end io_call_order;

print_track_header_info:
     proc (thip, report, all_sw);


dcl  all_sw		       bit (1);
dcl  report		       entry variable options (variable);
dcl  thip			       ptr;

dcl  header_dumped		       bit (1) init ("0"b);
dcl  i			       fixed bin;
dcl  last_sector		       fixed bin;

dcl  header_array		       (FORMAT_DATA_LEN (dev_type)) bit (36) based (addrel (thip, 1));


	call report ("^/position=(^d/^d)  ti=^2b^[  alternate=(^d/^d)^;^2s^]  tskip=^d,^d,^d  cf=^a",
	     thip -> thi.c0.cyl_lower + thip -> thi.c0.cyl_upper * 256, thip -> thi.c0.head, bit (thip -> thi.c0.ti),
	     (thip -> thi.c0.alt_cyl_lower + thip -> thi.c0.alt_cyl_upper + thip -> thi.c0.alt_head ^= 0),
	     thip -> thi.c0.alt_cyl_lower + thip -> thi.c0.alt_cyl_upper * 256, thip -> thi.c0.alt_head,
	     thip -> thi.c0.t_skip.distance, cond_flag (thip -> thi.c0.cf));
	call report (
	     "physical sector size = ^[512^;64^] words.^[Format of this disk by Honeywell has ^[not ^]completed.^;^s^]",
	     thip -> thi.c0.large_records, thip -> thi.c0.honeywell_formatted, ^(thip -> thi.c0.format_complete));
	if thip -> thi.c0.log_track then call report ("*** This is a log track. ***");
	call report ("^/skip1^5xskip2^5xcf^/");
	call report ("^8a^2x^8a^2x^a", skip_mess (thip -> thi.c0.skip (1)), skip_mess (thip -> thi.c0.skip (2)),
	     cond_flag (thip -> thi.c0.cf));
	if dev_type = msu0500devt then last_sector = 40;
	else if dev_type = msu0501devt then last_sector = 8;
	else last_sector = 0;
	do i = 1 to last_sector - 1;
	     call report ("^8a^2x^8a^2x^a", skip_mess (thip -> thi.c (i).skip (1)),
		skip_mess (thip -> thi.c (i).skip (2)), cond_flag (thip -> thi.c (i).cf));
	     end;

	if all_sw					/* dump it in hex also */
	     then call dump_header ();

	return;


cond_flag:
     proc (cf) returns (char (*));


dcl  cf			       bit (8) unal;


	if cf = "0011100"b then return ("No Error");
	else if cf = "00111001"b then return ("EDAC Error - Corrected");
	else if cf = "00111010"b then return ("EDAC Error - Uncorrectable");
	else return (char (cf));


     end cond_flag;


dump_header:
     proc ();


	if header_dumped then return;

	call report ("^(^/^4(^9.4b^2x^)^)", header_array);

	header_dumped = "1"b;

	return;


     end dump_header;


skip_mess:
     proc (skip) returns (char (8));


dcl  1 skip		       like thi.msu5xx_info.c0.skip unal;

dcl  1 retval		       unal,
       2 disp		       pic "zzzz9",
       2 space		       char (1) init (" "),
       2 type		       char (2);


	if ^skip.used then return ("none  ");

	if skip.gap_following_count then type = "FC";
	else if skip.gap_following_data then type = "FD";
	else type = "ID";
	disp = skip.displacement;

	return (string (retval));


     end skip_mess;


     end print_track_header_info;



     end rdisk_;




		    recover_volume_log.pl1          11/11/89  1129.5rew 11/11/89  0851.4      270594



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

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

recover_volume_log: proc;

/* This utility command is used in the rare case when a volume log is not available, either because it
   has been deleted, or  because we are reloading the RPV. It recovers the latest volume log
   by name from the dump volume that the requestor provides. It is the requestor's responsibility to provide the
   latest dump volume. */

/* Modified 6/79 by D. Vinograd to correct check for beginning of logical record */
/* Modified 11/79 by D. Vinograd to add -wd as control arg and add code to
   delete volume log if recovered when there is one already there */
/* Modified: 9/83 by GA Texada to allow multiple pvnames to be specified,
	   and to reformat and move includes.
	   */
/* Modified: 3/14/84 by GA Texada to allow for 'stranger' volume logs.		*/


/****^  HISTORY COMMENTS:
  1) change(88-10-10,Farley), approve(88-10-10,MCR8005),
     audit(88-10-15,Beattie), install(88-10-17,MR12.2-1173):
     Added new read routine and associated surrounding code to support the
     version 2 volume dump tapes.  These tapes have a pair of unique strings
     that delimit the object data of vtoce_type records.
  2) change(89-08-31,GWMay), approve(89-10-03,MCR8135),
     audit(89-10-04,Beattie), install(89-10-10,MR12.3-1089):
     Updated to process version 3 of backup_volume_log.incl.pl1 structures.
                                                   END HISTORY COMMENTS */


dcl (att_desc, input_volume_desc) char (256);
dcl (ac, argl, enl, itype, nargs, words_skipped, i, pvindex) fixed bin;
dcl (char_read, read_char) fixed bin (21);
dcl recovery_dir	     char (168);
dcl temp_dir	     char (168);			/* a place to put my pdir			*/
dcl (argp, iocbp)	     ptr;
dcl (debug, wd_specified, new_tape, first_input_volume, ok_to_abc, resynching) bit (1);
dcl delimited	     bit (1) aligned;		/* ON = reading object data delimited by unique matching strings */
dcl (irpvpvid, irpvlvid, time) bit (36);
dcl input_buf	     (divide (char_read, CHARS_PER_WORD, 17, 0)) bit (36) based (recordp);
dcl word		     (size (backup_volume_header)) bit (36) based (recordp);
dcl string	     bit (BITS_PER_WORD * size (backup_volume_header)) based (recordp);
dcl pattern_match_label  label;
dcl (ilvname, volname)   char (32);
dcl var_volname	     char (32) varying;
dcl (code, ignore)	     fixed bin (35);
dcl arg		     char (argl) based (argp);
dcl objectp	     ptr;
dcl input_buffer_ptr     ptr;
dcl input_buffer_start   fixed bin;
dcl input_buffer_len     fixed bin (21);
dcl old_256K_switch	     bit (2) aligned;
dcl tp		     (3) ptr;

dcl 1 rvl		     aligned based (rvlp),		/* structure to control multiple pv's		*/
    2 npvs	     fixed bin,			/* number of valid per_pv's			*/
    2 per_pv	     (maxpvs),			/* max that can be done (same as nargs)		*/
      3 pvname	     char (32),			/* pvname name to be recovered		*/
      3 volname	     char (32),			/* tape volume the log found on		*/
      3 ename	     char (32),			/* name to terminate			*/
      3 temp_logp	     ptr,				/* for pdir recovery			*/
      3 new_logp	     ptr,				/* ptr to recoverd log			*/
      3 time	     bit (36),			/* fs time of recover log			*/
      3 flags,
        4 abandoned	     bit (1) unal,			/* if I had to abandon this one		*/
        4 volog_found    bit (1) unal,			/* if I found his				*/
        4 mbz	     bit (34) unal,			/* RFU					*/
  rvlp		     ptr,
  maxpvs		     fixed bin;			/* will be set to nargs for allocation of rvl	*/

dcl (cleanup, linkage_error) condition;

dcl error_table_$data_loss fixed bin (35) ext;
dcl error_table_$noentry fixed bin (35) ext;
dcl error_table_$entlong fixed bin (35) ext;
dcl error_table_$segknown fixed bin (35) ext;
dcl error_table_$namedup fixed bin (35) ext;
dcl error_table_$device_end fixed bin (35) ext;
dcl error_table_$end_of_info fixed bin (35) ext;
dcl error_table_$badopt  ext fixed bin (35);
dcl sys_info$seg_size_256K fixed bin (19) ext static;
dcl sys_info$max_seg_size fixed bin (18) ext static;

dcl DEFAULT_RECOVERY_DIR char (168) int static init (">daemon_dir_dir>volume_backup") options (constant);
dcl myname	     char (32) static init ("recover_volume_log") options (constant);
dcl DELIMITED	     bit (1) aligned internal static options (constant)
		     init ("1"b);
dcl FORWARD_CHAR_POSITIONING fixed bin int static init (3) options (constant);

dcl hcs_$delentry_file   entry (char (*), char (*), fixed bin (35));
dcl hcs_$delentry_seg    entry (ptr, fixed bin (35));
dcl hphcs_$delentry_file entry (char (*), char (*), fixed bin (35));
dcl get_group_id_	     entry returns (char (32));
dcl get_pdir_	     entry () returns (char (168));
dcl hcs_$level_get	     entry returns (fixed bin);
dcl date_time_$fstime    entry (bit (36), char (*));
dcl adjust_bit_count_    entry (char (*), char (*), bit (1), fixed bin, fixed bin (35));
dcl cu_$arg_count	     entry (fixed bin, fixed bin (35));
dcl hcs_$fs_search_get_wdir entry (ptr, fixed bin (35));
dcl cu_$arg_ptr	     entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl com_err_	     entry options (variable);
dcl get_temp_segments_   entry (char (*), (*) ptr, fixed bin (35));
dcl ioa_$rsnnl	     entry options (variable);
dcl ioa_		     entry options (variable);
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$make_seg	     entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl hcs_$fs_move_seg     entry (ptr, ptr, fixed bin, fixed bin (35));
dcl hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35));
dcl hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
dcl hcs_$truncate_seg    entry (ptr, fixed bin (19), fixed bin (35));
dcl iox_$attach_ioname   entry (char (*), ptr, char (*), fixed bin (35));
dcl command_query_	     entry () options (variable);
dcl mdc_$pvname_info     entry (char (*), bit (36), char (*), bit (36), fixed bin, fixed bin (35));
dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));

dcl (addcharno, addr, divide, index, length, min, null, ptr, size, substr) builtin;

/* init local control variables */

    temp_dir = get_pdir_ ();				/* all recovery is done here first, moved after validation*/
    recovery_dir = DEFAULT_RECOVERY_DIR;
    debug, resynching, time, ok_to_abc = "0"b;
    first_input_volume = "1"b;
    input_volume_desc = "";
    old_256K_switch = ""b;
    tp (*) = null;
    bvlp, iocbp, rvlp = null ();
    code, maxpvs = 0;
    query_info.version = query_info_version_6;
    on cleanup call finish_;				/* set up cleanup handler */
    call cu_$arg_count (nargs, code);
    if nargs <= 0 then do;
argerr: call com_err_ (0, myname,
	   " USAGE: ^a pvnames [-input_volume_desc ""alternate attach decscription""] [-working_dir | -wd]",
	   myname);
        return;
      end;
    do ac = 1 to nargs;
      call cu_$arg_ptr (ac, argp, argl, code);
      if code ^= 0 then do;
	call com_err_ (code, myname);
	goto finish;
        end;

      if arg = "-input_volume_desc" then do;
	ac = ac + 1;
	call cu_$arg_ptr (ac, argp, argl, code);
	if code ^= 0 then do;
	    call com_err_ (code, myname, "Unable to access input volume desc");
	    goto finish;
	  end;
	input_volume_desc = arg;
        end;
      else if arg = "-working_dir" | arg = "-wd" then do;
	wd_specified = "1"b;
	recovery_dir = wdir_ ();
        end;
      else if substr (arg, 1, 1) = "-" then do;
	call com_err_ (error_table_$badopt, myname, "^a", arg);
	goto finish;
        end;
      else do;					/* should be a pvname, we will validate it later	*/
	if rvlp = null () then do;
	    maxpvs = (nargs - ac) + 1;		/* this is the max we could need		*/
	    allocate rvl set (rvlp);			/* allocate the space			*/
	    rvl.npvs = 0;				/* get ready				*/
	  end;

	rvl.npvs = rvl.npvs + 1;			/* bump to the next slot			*/
	rvl.pvname (rvl.npvs) = arg;			/* and put in the unvalidated name		*/

	rvl.volname (rvl.npvs), rvl.ename (rvl.npvs) = "";/* now, initialize the entry	*/
	rvl.temp_logp (rvl.npvs), rvl.new_logp (rvl.npvs) = null (); /* so the cleanup handler works properly*/
	rvl.time (rvl.npvs), rvl.flags (rvl.npvs) = "0"b;
        end;
    end;

    if (rvlp = null ()) | (rvl.npvs = 0) then do;		/* hmmmm, no pvnames given, complain		*/
        call com_err_ (0, myname, "No pvnames were specified.");
        goto finish;
      end;

    call setup_data_segments;
    if code ^= 0 then do;
        call com_err_ (code, myname, "Unable to get temp segs");
        goto finish;
      end;
    code = 0;

    call attach;

/* The search loop  reads successive records from the dump volume until it encounters a volume log with the name
   that matches pvname.  It then creates a segment, if one does not already exist and copies the data into it. The
   dump volume is read until the end of tape is reached. */

search_loop:
    pvindex = 0;					/* pvindex is set by read_volume_record		*/
    do while (pvindex = 0 & code = 0 & not_all_abandoned ());
						/* not_all_abandoned returns true if		*/
      call read_volume_record;			/* there is at least one pvname that we are still looking for*/
    end;
    if code ^= 0 then do;
        call com_err_ (code, myname, "Error while reading input volume");
        goto finish;
      end;
						/* create entry name */
    if pvindex ^= 0 then do;
        call ioa_$rsnnl ("^a.^a", rvl.ename (pvindex), enl, rvl.pvname (pvindex), "volog");
        if enl > length (rvl.ename (1)) then do;
	  code = error_table_$entlong;
	  call com_err_ (code, myname, "Error creating volog name for ^a. Recovery for it will be abandoned.",
	       rvl.pvname (pvindex));
	  rvl.abandoned (pvindex) = "1"b;		/* don't do this anymore!			*/
	  goto search_loop;
	end;

        call delete_make_and_move (temp_dir, bvlp, rvl.temp_logp (pvindex)); /* create and get ptr to segment */
        if rvl.abandoned (pvindex) then ;		/* sorry charlie...				*/
        else rvl.volog_found (pvindex) = "1"b;		/* only mark it if all operations worked...	*/
        goto search_loop;
      end;
finish_all_temp:

    if validate_all_vologs () then do;			/* ok, we've got all vologs in the process dir	*/
						/* they all must match as to who the RPV is	*/
        if ^wd_specified then do;			/* but, if we are NOT wd mode, then they also 	*/
						/* must belong to the mounted RPV		*/
	  call mdc_$pvname_info ("rpv", irpvpvid, ilvname, irpvlvid, itype, (0));
	  if irpvpvid ^= rvl.new_logp (1) -> backup_volume_log.info.root_pvid then do;
	      call com_err_ (0, myname, "Invalid attempt to recover a 'stranger' volume log. Use ""-wd"".");
	      goto finish;
	    end;
	end;
        do pvindex = 1 to rvl.npvs;
	if ((rvl.volog_found (pvindex)) & ^(rvl.abandoned (pvindex))) then
	  call delete_make_and_move (recovery_dir, rvl.temp_logp (pvindex), rvl.new_logp (pvindex));
        end;
      end;
    else call com_err_ (0, myname, "All volume logs must belong to the same RPV.");
						/* cleanup attachments, temp segs, and address space */
finish:
    call finish_;

    return;

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

all_vologs_found:
  proc () returns (bit (1));

dcl i		     fixed bin;
    do i = 1 to rvl.npvs;
      if (^rvl.volog_found (i)) then return ("0"b);	/* if one hasn't been found, return...		*/
    end;
    return ("1"b);
  end all_vologs_found;

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

not_all_abandoned: proc () returns (bit (1));

dcl i		     fixed bin;

    do i = 1 to rvl.npvs;
      if rvl.abandoned (i) then ;
      else return ("1"b);				/* at least one is still ok			*/
    end;
    return ("0"b);					/* nope, all abandoned			*/
  end not_all_abandoned;

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


detach: proc;

/* This proc closes and detaches the dump volume. */

    call iox_$close (iocbp, ignore);
    call iox_$detach_iocb (iocbp, ignore);
    iocbp = null;					/* be sure */

  end detach;

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


setup_data_segments: proc;

/* This proc sets up the data segments used during the recovery. */

    call get_temp_segments_ (myname, tp, code);
    if code ^= 0 then return;

    recordp = tp (1);
    objectp = tp (2);
    input_buffer_ptr = tp (3);
    call hcs_$set_256K_switch ("11"b, (""b), code);
    if code ^= 0 then return;
    call hcs_$set_max_length_seg (objectp, sys_info$seg_size_256K, code);
    if code ^= 0 then return;
    call hcs_$set_max_length_seg (input_buffer_ptr, sys_info$seg_size_256K, code);
    if code ^= 0 then return;
    input_buffer_start = 1;
    input_buffer_len = 0;
    return;

  end setup_data_segments;
						/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


attach: proc;

/* This proc queries the caller for the dump volume name, attaches to it and opens it. */


reask: call command_query_ (addr (query_info), var_volname, myname,
         "Type ^[next ^;^s^]most recent dump volume name (Type ""."" to quit): ", (^first_input_volume));
    if var_volname = "" then goto reask;
    if var_volname = "." then goto finish;
    volname = var_volname;

    first_input_volume = "0"b;

    if input_volume_desc ^= "" then
      call ioa_$rsnnl (input_volume_desc, att_desc, (0), volname);
    else call ioa_$rsnnl ("tape_mult_ ^a ^[-system^]", att_desc, (0), volname, ^debug);

    call iox_$attach_ioname ("input_volume", iocbp, att_desc, code);
    if code ^= 0 then do;
        call com_err_ (code, myname, "Unable to attach input volume with attach desc ^a", att_desc);
        goto finish;
      end;

    call iox_$open (iocbp, Stream_input, "0"b, code);
    if code ^= 0 then do;
        call com_err_ (code, myname, "Error opening input volume");
        goto finish;
      end;

  end attach;

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

delete_make_and_move:
  proc (temp_dir_in, ptr_in1, ptr_in2);

dcl temp_dir_in	     char (*),
  (ptr_in1, ptr_in2)     ptr;

    on linkage_error goto delerr;
    call hcs_$delentry_file (temp_dir_in, (rvl.ename (pvindex)), code);
    if code ^= 0 & code ^= error_table_$noentry then do;
        call hphcs_$delentry_file (temp_dir_in, (rvl.ename (pvindex)), code);
        if code ^= 0 then do;
delerr:	  call com_err_ (code, myname, "Unable to delete  ^a>^a. Recovery for it will be abandoned.",
	       temp_dir_in, rvl.ename (pvindex));
	  rvl.abandoned (pvindex) = "1"b;		/* well, forget this one...			*/
	  return;
	end;
      end;
    call hcs_$make_seg (temp_dir_in, (rvl.ename (pvindex)), "", 01010b, ptr_in2, code);
    if (code = 0
         | code = error_table_$namedup
         | code = error_table_$segknown) then ;
    else do;
        call com_err_ (code, myname, "Unable to create volog seg ^a>^a. Recovery for it will be abandoned.",
	   temp_dir_in, rvl.ename (pvindex));
        rvl.abandoned (pvindex) = "1"b;			/* forget this one 				*/
        return;
      end;
						/* copy data */
    call hcs_$fs_move_seg (ptr_in1, ptr_in2, 1, code);
    if code ^= 0 then do;
        call com_err_ (code, myname, "Unable to move volog from temp seg to target. Recovery for it will be abandoned.");
        rvl.abandoned (pvindex) = "1"b;
        return;
      end;
  end delete_make_and_move;

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


validate_all_vologs:
  proc () returns (bit (1));

dcl i		     fixed bin,
  mismatch	     bit (1) init ("0"b);

    do i = 1 to rvl.npvs;
      if rvl.temp_logp (i) -> backup_volume_log.info.root_pvid =
	 rvl.temp_logp (1) -> backup_volume_log.info.root_pvid then ;
      else mismatch = "1"b;
    end;
    return (^mismatch);
  end validate_all_vologs;


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


resynch_volume: proc;

/* This proc is used for error recovery. It reads the dump volume word by word looking for a match on the
   3 words which are part of the header of the logical dump record. When it gets a match it returns to specified label.
   While resynchronization is in progress , io error handling is suppressed except if we reach the end of a dump
   volume. This code is freely adapted from the volume reloader. */

    resynching = "1"b;
    input_buf (*) = "0"b;
    new_tape = "0"b;
    read_char = CHARS_PER_WORD * size (backup_volume_header);
    call read (recordp, read_char, char_read, ^DELIMITED, code);
    call check_input_error;

    if new_tape then goto search_loop;
    words_skipped = 0;
test: if word (1) = pattern1 & word (4) = pattern2 & word (7) = pattern3 then do;
        call com_err_ (0, myname, "Synchronization completed ^d words skipped",
	   words_skipped);
        resynching = "0"b;
        delimited = "0"b;
        code = 0;
        goto pattern_match_label;
      end;

    string = substr (string, 37, (size (backup_volume_header) - 1) * BITS_PER_WORD);
    new_tape = "0"b;
    read_char = CHARS_PER_WORD;
    call read (addr (word (size (backup_volume_header))),
         read_char, char_read, ^DELIMITED, code);
    call check_input_error;
    if new_tape then goto search_loop;

    words_skipped = words_skipped + 1;
    if words_skipped > 1000000 then do;			/* put a limit on it */
        call com_err_ (0, myname, "Resynchronization failed");
        code = error_table_$end_of_info;
        call check_input_error;
        goto search_loop;
      end;
    goto test;

  end resynch_volume;

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


skip_chars: proc;

/* This proc skips forward on a dump volume. */

    call read (objectp, read_char, char_read, delimited, code);
    call check_input_error;

  end skip_chars;

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


check_input_error: proc;

/* This proc is used to check all io errors after a read request.  If no error we return.
   If we are at the end of the dump volume, then it is detached. If a volume log has not been found, a new dump volume is
   requested. Otherwise we are done. If the error is the result of a bad read we start resynchronization.
   If it has already been started we just return. */

    new_tape = "0"b;
    if read_char ^= char_read | code ^= 0 then do;
        if (code = error_table_$end_of_info) | (code = error_table_$device_end) then do;
	  call detach;				/* if all have been found OR all 		*/
	  if (all_vologs_found ()) | (^not_all_abandoned ()) then goto finish_all_temp;
						/* have been abandoned, then forget it...	*/
	  else do;
	      call attach;				/* try the next tape			*/
	      new_tape = "1"b;
	    end;
	  return;
	end;
        else if resynching then do;
	  call com_err_ (code, myname, "I/O error reading input volume");
	  call detach;
	  goto finish;
	end;
        else if ^resynching then do;
	  if read_char ^= char_read then do;
	      if code = error_table_$data_loss then
	        call com_err_ (code, myname, "Incomplete object detected");
	      else do;
		if code = 0 then call com_err_ (code, myname, "Read did not complete");
		else call com_err_ (code, myname, "I/O error reading input volume");
	        end;
	    end;
	  else do;
	      if code = -1 then call com_err_ (0, myname, "Invalid dump record header");
	      else call com_err_ (code, myname, "I/O error reading input volume");
	    end;
	  call ioa_ ("^a: Resynching started", myname);
	  call resynch_volume;
	end;
      end;
  end check_input_error;

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


read_volume_record: proc;

/* This proc reads a logical dump record, and checks to see it it is a volume log with the name pvname. If
   so it returns with pvindex pointing to the correct rvl entry. If the logical dump record is not what we
   are looking for, the next logical dump record is examined. */

    pattern_match_label = pattern_match;
    new_tape = "0"b;
    delimited = "0"b;
    read_char = CHARS_PER_WORD * size (backup_volume_header);
    call read (recordp, read_char, char_read, delimited, code);
    call check_input_error;
    if new_tape then return;
    if backup_volume_record.pattern1 ^= pattern1
         | backup_volume_record.pattern2 ^= pattern2
         | backup_volume_record.pattern3 ^= pattern3 then do;
        code = -1;
        call check_input_error;
      end;
pattern_match:
    read_char = backup_volume_record.rec1_len - size (backup_volume_header) * CHARS_PER_WORD;
    call read (ptr (recordp, size (backup_volume_header)),
         read_char, char_read, delimited, code);
    call check_input_error;
    if new_tape then return;
    if backup_volume_record.rec1_type ^= volume_log_type then do;
        read_char = backup_volume_record.rec2_len;
        if backup_volume_record.rec1_type = vtoce_type &
	   backup_volume_record.version > backup_volume_record_version_1
	   then delimited = "1"b;			/* object data is delimited */
        call skip_chars;
        return;
      end;

    bvlp = recordp;
    if (backup_volume_log.version = backup_volume_log_version_1) |
         (backup_volume_log.version = backup_volume_log_version_2) |
         (backup_volume_log.version = backup_volume_log_version_3) then ;
    else do;
        call com_err_ (0, myname, "Invalid volume log version");
        return;
      end;
    do pvindex = 1 to rvl.npvs;			/* include the check for previous abandonment here...*/
      if (backup_volume_log.pvname = rvl.pvname (pvindex)) & ^(rvl.abandoned (pvindex)) then do;
	if (rvl.volog_found (pvindex)) & (rvl.time (pvindex) > backup_volume_log.time_dumped) then do;
	    pvindex = 0;				/* it is older than the one we already have	*/
	    return;				/* we don't want this one			*/
	  end;
	rvl.time (pvindex) = backup_volume_log.time_dumped;
	rvl.volname (pvindex) = volname;
	return;					/* pvindex is set 				*/
        end;
    end;
    pvindex = 0;					/* not found				*/
  end read_volume_record;

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

read: proc (return_buffer_ptr,
       Nrequested_chars,
       Nreturned_chars,
       Sdelimited,
       code);

dcl return_buffer_ptr    ptr,
  Nrequested_chars	     fixed bin (21),
  Nreturned_chars	     fixed bin (21),
  Sdelimited	     bit (1) aligned,
  code		     fixed bin (35);

dcl input_buffer	     char (256 * CHARS_PER_PAGE)
		     based (input_buffer_ptr);

dcl return_string	     char (Nrequested_chars)
		     based (return_buffer_ptr);

dcl Nassign_chars	     fixed bin (21),
  Nread_chars	     fixed bin (21),
  end_of_record	     fixed bin,
  tape_check1 /* bit (72) */ char (8),
  tape_check2 /* bit (72) */ char (8);

    Nreturned_chars, Nread_chars, code = 0;

    do while (Nreturned_chars < Nrequested_chars & code = 0);
      if input_buffer_len = 0 then do;
	input_buffer_start = 1;

	if Sdelimited & Nreturned_chars = 0 then do;
	    call iox_$get_chars (iocbp,
	         addr (tape_check1), length (tape_check1), Nread_chars, code);
	    if code ^= 0 then return;
	  end;

	if return_buffer_ptr = null then do;
	    call iox_$position (iocbp, FORWARD_CHAR_POSITIONING,
	         Nrequested_chars - Nreturned_chars, code);
	    Nreturned_chars = Nreturned_chars + Nrequested_chars;
	  end;
	else do;
	    call iox_$get_chars (iocbp,
	         addcharno (return_buffer_ptr, Nreturned_chars),
	         Nrequested_chars - Nreturned_chars, Nread_chars, code);
	    Nreturned_chars = Nreturned_chars + Nread_chars;
	  end;
	if code ^= 0 then return;

	if Sdelimited then do;
	    call iox_$get_chars (iocbp,
	         addr (tape_check2), length (tape_check2), Nread_chars, code);
	    if code ^= 0 then
	      return;

	    if tape_check1 ^= tape_check2 then do;
						/* found a short segment, move       */
						/* return string into the temp input */
						/* buffer and start parsing          */
	        input_buffer_len = Nreturned_chars;
	        substr (input_buffer, 1, input_buffer_len) =
		   return_string;
	      end;
	  end;
        end;

      else
	 if Sdelimited then do;
	tape_check1 = substr (input_buffer,
	     input_buffer_start, length (tape_check1));
	tape_check2 = "";
	input_buffer_start =
	     input_buffer_start + length (tape_check1);
	input_buffer_len =
	     input_buffer_len - length (tape_check1);
        end;

      if input_buffer_len > 0 then do;
	Nassign_chars =
	     min (input_buffer_len, Nrequested_chars);

	if Sdelimited then do;
	    if tape_check1 ^= tape_check2 then do;
	        end_of_record = index (substr (input_buffer, input_buffer_start,
		   input_buffer_len), tape_check1);
	        if end_of_record > 0 then do;
		  Nassign_chars = end_of_record - 1;
		  if Nrequested_chars ^= Nassign_chars then
		    code = error_table_$data_loss;
		end;
	      end;
	  end;

	if return_buffer_ptr ^= null then
	  return_string = substr (input_buffer,
	       input_buffer_start, Nassign_chars);
	Nreturned_chars = Nassign_chars;

	input_buffer_start =
	     input_buffer_start + Nassign_chars;
	input_buffer_len =
	     input_buffer_len - Nassign_chars;

	if Sdelimited & input_buffer_len > 0 then do;
	    input_buffer_start =
	         input_buffer_start + length (tape_check2);
	    substr (input_buffer, 1, input_buffer_len) =
	         substr (input_buffer, input_buffer_start,
	         input_buffer_len - length (tape_check2))
	         || tape_check2;
	    input_buffer_start = 1;
	  end;
        end;
    end;

    return;
  end read;
						/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


wdir_: proc returns (char (168) aligned);

/* This proc returns the pathname of the working directory. */


dcl wdir		     char (168) aligned;
    call hcs_$fs_search_get_wdir (addr (wdir), ignore);
    return (wdir);
  end wdir_;

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


time_string: proc (i) returns (char (24));
dcl string	     char (24),
  i		     fixed bin;
    call date_time_$fstime ((rvl.time (i)), string);
    return (string);
  end time_string;

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


finish_: proc;
    if iocbp ^= null then call detach;
    if tp (1) ^= null then do;
        call hcs_$truncate_seg (objectp, 0, ignore);	/* clean up our 256K segs */
        call hcs_$truncate_seg (input_buffer_ptr, 0, ignore);
        call hcs_$set_max_length_seg (objectp, (sys_info$max_seg_size), ignore);
        call hcs_$set_max_length_seg (input_buffer_ptr, (sys_info$max_seg_size), ignore);
        call release_temp_segments_ (myname, tp, ignore);
        call hcs_$set_256K_switch (old_256K_switch, (""b), ignore);
      end;
    if get_group_id_ () ^= "Initializer.SysDaemon.z" & hcs_$level_get () ^= 1 then ok_to_abc = "1"b;
    if rvlp ^= null () then do;
        do i = 1 to rvl.npvs;
	if rvl.temp_logp (i) ^= null () then call hcs_$delentry_seg (rvl.temp_logp (i), (0));
	if rvl.new_logp (i) ^= null then do;
	    if ok_to_abc then call adjust_bit_count_ (wdir_ (), (rvl.ename (i)), "0"b, (0), ignore);
	    call hcs_$terminate_noname (rvl.new_logp (i), ignore);
	  end;
	call ioa_ ("Volume log ^a ^[recovered from tape volume ^a, dump time ^a^;not recovered^s^s ^]", rvl.pvname (i),
	     (rvl.volog_found (i)), rvl.volname (i), time_string (i));
        end;
        free rvl;
      end;
  end finish_;
%page; %include backup_volume_log;
%include backup_pvol_info;
%page; %include fs_vol_label;
%page; %include backup_volume_record;
%include backup_volume_header;
%include backup_static_variables;
%page; %include vtoce;
%page; %include query_info;
%page; %include iox_dcls;
%page; %include iox_modes;
%page; %include system_constants;
  end recover_volume_log;





		    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
