



		    bce_save.pl1                    11/11/89  1135.4r w 11/11/89  0826.7     1242702



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

/* format: style4,declareind10,dclind10,idind20,indattr,delnl,insnl,ifthenstmt */

bce_save:
     procedure (ss_info_ptr);

/**** NOTE:
      All the internal procedures have been carefully setup to be QUICK
      (i.e. they all share the main stack frame). Also routines that are
      not required in the main stream save/restore loop, that do not reference
      main stream procedures, can be in bce_save_util_. */

/****^  HISTORY COMMENTS:
  1) change(86-09-18,Farley), approve(86-07-18,MCR7439),
     audit(86-09-24,Fawcett), install(86-10-20,MR12.0-1189):
     BCE Save/Restore program. Written November 1985 - July 1986
     by Paul Farley.
  2) change(87-01-21,Farley), approve(87-02-25,MCR7615), audit(87-03-05,GWMay),
     install(87-03-30,MR12.1-1018):
     Corrected to properly free the I/O buffer after detecting an invalid tape
     label in READ_TAPE_LABEL.
  3) change(87-05-21,Farley), approve(87-07-07,MCR7705),
     audit(87-07-21,Fawcett), install(87-07-31,MR12.1-1051):
     Changed to properly set si.tcbx when -display_info_tape is used.
  4) change(87-07-07,Farley), approve(87-07-17,MCR7733),
     audit(87-07-21,Fawcett), install(87-07-31,MR12.1-1051):
     Changed most of the calls to ioa_ and com_err_ to calls to syserr and
     syserr$error_code so that a time stamp will be included in the output..
     Changed the code to chain the set tape density I/O to the first read
     or write at BOT. Changed the write error recovery at BOT to consist of
     a rewind followed by a set-density and then the retry of the write.
  5) change(87-07-31,Farley), approve(87-07-31,MECR0003),
     audit(87-07-31,Fawcett), install(87-07-31,MR12.1-1051):
     Corrected FLUSH_BUFFERS and created FREE_OR_REQUEUE_TAPE_IO to properly
     close out a tape after EOT has been detected.. (phx20930)
  6) change(87-08-03,Farley), approve(87-08-06,MECR0004),
     audit(87-08-05,Fawcett), install(87-08-06,MR12.1-1063):
     Changed DISK_RUN to check for the oldest DISK_BUSY buffer, to correct a
     problem with PV records on tape being out of sequence.
  7) change(87-08-28,Farley), approve(87-08-28,MCR7758),
     audit(87-08-28,Fawcett), install(87-09-01,MR12.1-1095):
     Offically install the above two MECRed changes..
  8) change(87-11-04,Farley), approve(88-02-26,MCR7811),
     audit(88-03-04,Fawcett), install(88-03-15,MR12.2-1035):
     Changed to always call bce_save_util_$premount_check when doing a restore
     and let it check the usable tape device count.
     
     Added validity checking of the next_tape_number, so that the
     tape_seq_number will not become inconsistent when this next number is
     calculated incorrectly from the "Info" tape or its replacement.
     
     Added a RELOCATE_RECORD procedure for attempting to find a missing tape
     record during a restore.  It has been found that sometimes a tape device
     can skip a record that is REALLY on the tape, due to some device
     malfunction.
  9) change(87-11-16,Farley), approve(88-02-26,MCR7811),
     audit(88-03-04,Fawcett), install(88-03-15,MR12.2-1035):
     Added clearing of the unused VTOC area before doing a restore.  This
     is to guarantee that there are no "bogus" VTOCEs left laying around.
 10) change(88-04-12,Farley), approve(88-05-31,MCR7902),
     audit(88-05-31,Fawcett), install(88-07-05,MR12.2-1052):
     Added checking for tape record sequence errors while doing a save.
     Corrected bug in EOT record processing, so that duplicate records don't
     get written to tape.  Now force the mount message for the restart tape by
     unloading any tape that may be mounted on the device, to allow better
     operator understanding of what is going on.
                                                   END HISTORY COMMENTS */

	restoring = NO;
	my_name = "save";
	goto common;

bce_save$bce_restore:
     entry (ss_info_ptr);

	restoring = YES;
	my_name = "restore";
common:
	srip = addr (save_restore_info);
	unspec (sri) = ""b;
	sri.version_id = sri_version_1;
	sri.set_count = 0;
	sri.doing_restore = restoring;
	sri.whoami = my_name;
	sri.cf_arrayp = addr (cf_array);
	sri.part_area_ptr = addr (part_area (1, 1));
	sri.pv_area_ptr = addr (pv_area (1, 1));
	sri.tcb_area_ptr = addr (tcb_area (1, 0));
	iobp = null ();
	unspec (cf_array (*)) = ""b;
	unspec (part_area (*, *)) = ""b;
	unspec (pv_area (*, *)) = ""b;
	unspec (tcb_area (*, *)) = ""b;
	disk_post_area_ptr = null ();
	ioi_post_area_ptr = null ();
	sri.set_infop = addr (set_info);
	unspec (set_info (*)) = ""b;
	do setx = lbound (set_info, 1) to hbound (set_info, 1);
						/* initialize array */
	     set_info (setx).version_id = si_version_1;
	     set_info (setx).bit_map_ptr, set_info (setx).datap, set_info (setx).info_tape_label_ptr,
		set_info (setx).part_ptr, set_info (setx).pv_ptr, set_info (setx).tape_label_ptr,
		set_info (setx).tcb_ptr, set_info (setx).vol_preamble_ptr, set_info (setx).vol_map_ptr,
		set_info (setx).vol_info_ptr = null (); /* so cleanup works */
	end;

	on cleanup call CLEANUP;			/* will happen on signal of sub_request_abort_ */

	if ss_info_ptr ^= null () then do;
	     call cu_$arg_count_rel (arg_count, ss_info.arg_list_ptr, code);
	     if code ^= 0 then do;
		call com_err_ (code, my_name, "cu_$arg_count_rel");
		call ABORT;
	     end;
	end;
	else arg_count = 0;

	if arg_count = 0 then do;
	     call ioa_ ("Usage is: ^a {-set} CF_1 {... CF_N} {-set CF_1 {... CF_N}}^/^-{-restart_set CF_1 {... CF_N}}",
		my_name);
	     call ABORT;
	end;

	ss_info.flags.request_handling_opr_aborts = YES;	/* let everybody know */
	display_info_tape = NO;
	do argx = 1 to arg_count;
	     call cu_$arg_ptr_rel (argx, arg_ptr, arg_lth, code, ss_info.arg_list_ptr);
	     if code ^= 0 then do;
		call com_err_ (code, my_name, "cu_$arg_ptr_rel");
		call ABORT;
	     end;
	     if substr (arg, 1, 1) ^= "-" then do;
		if sri.set_count = 0 then sri.set_count = 1;
		sri.cf_count = sri.cf_count + 1;
		if sri.cf_count > hbound (cf_array, 1) then do;
		     call ioa_ ("^a: Too many control files specified on the command line.", my_name);
		     call ABORT;
		end;
		if arg_lth > length (cf_array (sri.cfx).name) then do;
		     call ioa_ ("^a: Illegal control file name ""^a"".", my_name, arg);
		     call ABORT;
		end;
		unspec (cf_array (sri.cf_count)) = ""b;
		do sri.cfx = lbound (cf_array, 1) to sri.cf_count - 1
		     while (cf_array (sri.cfx).name ^= arg | (cf_array (sri.cfx).set ^= sri.set_count & ^restoring));
		end;
		if sri.cfx ^= sri.cf_count then do;
		     call ioa_ ("^a: Control file ""^a"" has be multiply specified.", my_name, arg);
		     call ABORT;
		end;
		cf_array (sri.cfx).name = arg;
		cf_array (sri.cfx).set = sri.set_count;
		cf_array (sri.cfx).length = 0;
		cf_array (sri.cfx).ptr = null ();
	     end;
	     else if arg = "-set" then do;
		sri.set_count = sri.set_count + 1;
		if sri.set_count > hbound (set_info, 1) then do;
		     call ioa_ ("^a: Too many SETs specified.", my_name);
		     call ABORT;
		end;
		set_info (sri.set_count).restart = NO;
	     end;
	     else if arg = "-restart_set" | arg = "-restart" | arg = "-rt" then do;
		sri.set_count = sri.set_count + 1;
		if sri.set_count > hbound (set_info, 1) then do;
		     call ioa_ ("^a: Too many SETs specified.", my_name);
		     call ABORT;
		end;
		set_info (sri.set_count).restart = YES;
	     end;
	     else if arg = "-debug" | arg = "-db" then sri.debug = YES;
	     else if (arg = "-display_info_tape" | arg = "-dit") & restoring then do;
		argx = argx + 1;
		call cu_$arg_ptr_rel (argx, arg_ptr, arg_lth, code, ss_info.arg_list_ptr);
		if code ^= 0 then do;
		     call com_err_ (code, my_name, "Getting tape drive arg for display_info_tape.");
		     call ABORT;
		end;
		sri.set_count, setx = 1;
		si_ptr = addr (set_info (setx));
		si.tcbx, si.tape_count, si.usable_tape_devices = 1;
		si.tape_set = "display_info_tape";
		si.tcb_ptr, tcbp = addr (tcb_area (setx, si.tcbx));
		unspec (tcb) = ""b;
		tcb.name = arg;			/* insert tape drive name */
		tcb.density = ANY_DENSITY;
		display_info_tape = YES;
	     end;
	     else do;
		call ioa_ ("^a: Bad argument ^a.", my_name, arg);
		call ABORT;
	     end;
	end;

	if display_info_tape then do;			/* special "Info" tape display */
	     call SETUP;
	     setx = 1;				/* force primary set */
	     call SET_PTRS;
	     call ATTACH_TAPE;
	     if ^tcb.attached then goto EXIT;
	     call bce_save_util_$init_buffers (srip);
	     si.need_info_tape = YES;
	     call READ_TAPE_LABEL;
	     call bce_save_util_$display_info_tape (srip);
	     goto EXIT;
	end;

	do setx = lbound (set_info, 1) to sri.set_count;
	     call SET_PTRS;
	     si.tape_set = "";
	     si.complete = NO;
	     si.tape_count = 0;
	     si.usable_tape_devices = 0;
	     si.pv_count = 0;
	     si.part_count = 0;
	     do sri.cfx = 1 by 1 while (sri.cfx <= sri.cf_count);
		if cf_array (sri.cfx).set = setx then call bce_save_util_$scan_control_file (srip);
	     end;
	     if si.tape_set = "" then do;
		call ioa_ ("^a: No tape set name defined for set-^d.", my_name, setx);
		call ABORT;
	     end;
	     if si.tape_count = 0 then do;
		call ioa_ ("^a(^a): No tape drives defined.", my_name, si.tape_set);
		call ABORT;
	     end;
	     if si.pv_count = 0 & si.part_count = 0 then do;
		call ioa_ ("^a(^a): No physical volumes or partitions defined.", my_name, si.tape_set);
		call ABORT;
	     end;
	end;

	call SETUP;				/* setup pointers */

	do setx = lbound (set_info, 1) to sri.set_count;
	     call SET_PTRS;
	     do si.tcbx = FIRST_TAPE_DEV_IDX to si.tape_count;
						/* try attaching each tape device requested */
		si.tcb_ptr, tcbp = addr (tcb_array (si.tcbx));
		call ATTACH_TAPE;
		if ^tcb.attached
		then goto remove_tape_dev;
		else do;
		     if ^TAPE_DEVICE_USABLE () then do;
remove_tape_dev:
			call syserr (ANNOUNCE,
			     "^a(^a): Device ^a is being removed from the tape device list.^66t***", my_name,
			     si.tape_set, tcb.name);
			tcb.removed = YES;
			si.usable_tape_devices = si.usable_tape_devices - 1;
		     end;
		     if tcb.tape_mounted then call UNLOAD_TAPE;
		     if tcb.attached then call DETACH_TAPE;
		end;
	     end;
	     do si.tcbx = FIRST_TAPE_DEV_IDX to si.tape_count while (tcb_array (si.tcbx).removed);
	     end;
	     if si.tcbx > si.tape_count then do;
		call syserr (ANNOUNCE, "^a(^a): No usable tape devices left in list.", my_name, si.tape_set);
		call ABORT;
	     end;
	     si.tcb_ptr, tcbp = addr (tcb_array (si.tcbx));
	     call ATTACH_TAPE;			/* re-attach first good device */
	     if ^tcb.attached then goto remove_tape_dev;
	     call bce_save_util_$init_buffers (srip);

	     call ioa_ ("");
	     call syserr (ANNOUNCE, "^a(^a): The following tape device(s) will be used:^/", my_name, si.tape_set);
	     tape_drive_string = "";
	     do i = FIRST_TAPE_DEV_IDX to si.tape_count;
		if ^tcb_array (i).removed then do;
		     tape_drive_string = tape_drive_string || tcb_array (i).name || " ";
		     if length (tape_drive_string) > 50 then do;
						/* 6 per line */
			call ioa_ ("^-^a", tape_drive_string);
			tape_drive_string = "";
		     end;
		end;
	     end;
	     if tape_drive_string ^= "" then call ioa_ ("^-^a", tape_drive_string);

	     do partx = lbound (part_array, 1) to si.part_count;
						/* see if pv defined */
		do si.pvx = lbound (pv_array, 1) to si.pv_count
		     while (pv_array (si.pvx).name ^= part_array (partx).pv_name);
		end;
		if si.pvx > si.pv_count then do;	/* not found, make one */
		     si.pv_count = si.pv_count + 1;
		     if si.pv_count > hbound (pv_array, 1) then do;
			call syserr (ANNOUNCE, "^a(^a): No room to describe PV ^a for part ^a.", my_name,
			     si.tape_set, part_array (partx).pv_name, part_array (partx).name);
			call ABORT;
		     end;
		     si.pv_ptr, pvp = addr (pv_array (si.pv_count));
		     si.part_ptr, partp = addr (part_array (partx));
		     pv.name = part.pv_name;
		     pv.device = part.device;
		     pv.pvtx = part.pv_pvtx;
		     pv.all = NO;
		     pv.only_part = YES;		/* only saving/restoring volume part(s) */
		     pv.part_requested = YES;
		     pv.all_parts = (part.name = ALL_PARTS);
		     pv.restart.rec_on_pv, pv.restart.rec_in_type = 0;
		     pv.complete = NO;
		     pv.removed = NO;
		end;
		else do;
		     pv_array (si.pvx).part_requested = YES;
						/* show partition requested */
		     if ^pv_array (si.pvx).all_parts
		     then pv_array (si.pvx).all_parts = (part_array (partx).name = ALL_PARTS);
		end;
	     end;

	     if restoring
	     then si.need_info_tape = YES;
	     else si.need_info_tape = NO;
	     call SETUP_SET;			/* finish setup of this set */
	     si.restart = NO;			/* turn OFF restart flag */

	     do si.pvx = lbound (pv_array, 1) to si.pv_count while (pv_array (si.pvx).removed);
	     end;
	     if si.pvx > si.pv_count then do;
		call syserr (ANNOUNCE, "^a(^a): No Physical Volumes left to ^a.", my_name, si.tape_set, my_name);
		call ABORT;
	     end;

	     call bce_save_util_$thread_partition_list (srip);
						/* Thread partitions & connect to pv */
	     si.pvx = 1;
	     si.pv_ptr, pvp = addr (pv_array (si.pvx));	/* set back to the beginning */
	end;

	call bce_query$yes_no (yes_no, "^/^a: Would you like to continue?", my_name);
	if ^yes_no then goto EXIT;

/* Begin Main Processing Loop */

	done = NO;
	do while (^done);
	     do setx = lbound (set_info, 1) to sri.set_count;
		call SET_PTRS;
		if si.restart_requested then goto RESTART;
						/* restart this set */
		if ^si.complete
		then if ^pv.removed & ^pv.complete then do;
			if restoring
			then call RESTORE_PV;
			else call SAVE_PV;
		     end;
		     else do;
			do si.pvx = lbound (pv_array, 1) to si.pv_count
			     while (pv_array (si.pvx).removed | pv_array (si.pvx).complete);
			end;
			if si.pvx > si.pv_count then do;
			     if ^restoring then do;	/* wrap up save */
				call WRITE_TAPE_EOR;/* end-of-reel record */
				call NEXT_TAPE_DEVICE;
				if TAPE_DEVICE_READY () then do;
				     call bce_query$yes_no (yes_no, "^a(^a): OK to write ""Info"" tape on ^a? ",
					my_name, si.tape_set, tcb.name);
				     if ^yes_no then call UNLOAD_TAPE;
				end;
				si.need_info_tape = YES;
						/* setup to write "Info" tape */
				si.written_tape_label = NO;
				call WRITE_TAPE_LABEL;
				call WRITE_TAPE_EOR;
				si.need_info_tape = NO;
			     end;
			     call UNLOAD_TAPE;	/* unload the last tape */
			     call syserr (ANNOUNCE, "^a(^a): ^a complete...", my_name, si.tape_set, my_name);
			     si.complete = YES;
			end;
			else si.pv_ptr, pvp = addr (pv_array (si.pvx));
		     end;
		else do;
		     do i = lbound (set_info, 1) to sri.set_count while (set_info (i).complete);
		     end;
		     if i > sri.set_count then done = YES;
						/* ALL DONE */
		end;
		call CHECK_ABORT;			/* user wanta quit? */
NEXT_SET:
	     end;
	end;

/* Program EXIT */

EXIT:
	call CLEANUP;
	return;
%skip (4);
/**** The following two labels are transfered to from the
      TAPE_ERROR_RECOVERY routine when either the "remove" or "restart"
      requests are given.  The non-local transfers are done so that all
      the internal procedures can be QUICK (i.e. all share the same stack
      frame). */

REMOVE_N_RESTART:
	tcb.removed = YES;
	si.usable_tape_devices = si.usable_tape_devices - 1;
RESTART:
	if tcb.removed
	then call NEXT_TAPE_DEVICE;			/* go to next one */
	else do;					/* re-attach this one */
	     if tcb.ioi_index ^= 0 then do;
		if tcb.tape_mounted then call UNLOAD_TAPE;
		call DETACH_TAPE;
	     end;
	     call ATTACH_TAPE;
	     call bce_save_util_$init_buffers (srip);
	     tcb.eot = NO;
	end;
	si.restart = YES;				/* to inform rest of code */
	si.restart_requested = NO;			/* nolonger needed */
	do si.pvx = lbound (pv_array, 1) to si.pv_count;
	     pv_array (si.pvx).restart.rec_on_pv, pv_array (si.pvx).restart.rec_in_type = 0;
	     pv_array (si.pvx).complete = NO;
	end;
	do partx = lbound (part_array, 1) to si.part_count;
	     part_array (partx).complete = NO;
	end;
	call SETUP_SET;				/* restart this set */
	if si.complete then goto NEXT_SET;		/* no need to restart */
	si.pvx = 1;
	si.pv_ptr, pvp = addr (pv_array (si.pvx));	/* set back to the beginning */
	si.restart = NO;				/* nolonger needed */
	call syserr (ANNOUNCE, "^a: Restarting ^a of set ""^a"" on ^a.^/", my_name, my_name, si.tape_set, tcb.name);
	goto NEXT_SET;				/* go back to normal processing */
%page;
/**** ABORT - Routine to force program termination and cleanup to be done. */

ABORT:
     procedure;

	signal sub_request_abort_;
	return;
     end ABORT;
%skip (4);
/**** ATTACH_TAPE - Attach tape device. */

ATTACH_TAPE:
     procedure;

	tcb.device = bin (substr (tcb.name, 6, 2), 17);
	si.tape_rec_count = 0;
	tcb.attached = NO;
	call bce_save_util_$ioi_attach (srip);
	tcb.write_tape = ^restoring;
	tcb.fips = bce_save_util_$is_fips_device (srip);
	call SET_DEVICE_OPTIONS;
	if ^tcb.surveyed
	then call DETACH_TAPE;
	else tcb.attached = YES;
	tcb.records_written = 0;
	tcb.retry_count = 0;
	tcb.one_eof = NO;
	tcb.density_set = NO;
	tcb.tape_vol_number = "";			/* don't know, yet. */
	return;
     end ATTACH_TAPE;
%page;
/**** Small routine to scan the buffer list looking for a free buffer. */

BUFFER_AVAILABLE:
     procedure () returns (bit (1));

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = FREE then return (YES);
	end;
	return (NO);
     end BUFFER_AVAILABLE;
%page;
/**** Routine to find the number of buffers assigned to a given state. */

BUFFER_COUNT:
     procedure (p_buf_state) returns (fixed bin);
dcl	buf_count		fixed bin;
dcl	p_buf_state	fixed bin;
dcl	temp_bufp		ptr;

	buf_count = 0;
	do temp_bufp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, temp_bufp -> iob.next_bufx)
	     while (rel (temp_bufp) ^= ""b);
	     if temp_bufp -> iob.state = p_buf_state then buf_count = buf_count + 1;
	end;
	return (buf_count);
     end BUFFER_COUNT;
%page;
/**** Routine to check if the operator has requested an abort, by using
      the console "request" key.  This routine is similar to the program
      bce_check_abort, but allows for more flexible responses. */

CHECK_ABORT:
     procedure;

	if ^wired_hardcore_data$abort_request then return;
query_abort:
	wired_hardcore_data$abort_request = NO;
	call bce_query (opr_input, "^a: Abort request: ", my_name);
	if opr_input = "no" | opr_input = "n" then return;
	else if opr_input = "abort" then call ABORT;
	else if substr (opr_input, 1, 4) = "stop" then do;
	     opr_input = after (opr_input, " ");
	     do i = lbound (set_info, 1) to sri.set_count while (set_info (i).tape_set ^= opr_input);
	     end;
	     if i > sri.set_count then do;
bad_set_input:
		call ioa_ ("Invalid tape set ""^a"".", opr_input);
		goto query_abort;
	     end;
	     if ^set_info (i).complete then do;
		call syserr (ANNOUNCE, "^a: Stopping ^a of set ""^a"".", my_name, my_name, set_info (i).tape_set);
		set_info (i).complete = YES;		/* abort by marking complete */
		return;
	     end;
	     call ioa_ ("^a: ^a set ""^a"" is no longer active.", my_name, my_name, set_info (i).tape_set);
	     goto query_abort;
	end;
	else if substr (opr_input, 1, 7) = "restart" then do;
	     opr_input = after (opr_input, " ");
	     do i = lbound (set_info, 1) to sri.set_count while (set_info (i).tape_set ^= opr_input);
	     end;
	     if i > sri.set_count then goto bad_set_input;
	     if ^set_info (i).complete then do;
		set_info (i).restart_requested = YES;	/* set flag to allow handling at proper time */
		return;
	     end;
	     call ioa_ ("^a: ^a set ""^a"" is already complete.", my_name, my_name, set_info (i).tape_set);
	     goto query_abort;
	end;
	else if opr_input = "help" | opr_input = "?" then do;
	     call ioa_ ("Valid inputs are:
no, n^21t- Go back to work.
abort^21t- Abort entire ^a.
restart TAPE_SET^21t- Restart ^a of just one set.
stop TAPE_SET^21t- Abort ^a of just one set.", my_name, my_name, my_name);
	     goto query_abort;
	end;
	else do;
	     call ioa_ ("Invalid input ""^a"". Type ""help"" or ""?"" for valid inputs.", opr_input);
	     goto query_abort;
	end;
     end CHECK_ABORT;
%page;
/**** Routine to validate the status returned from doing a tape connect.
      It uses the tape_error_data data segment for help in interpretation
      and analysis of the error.  The routine will retry the error if
      needed and call the error recovery routine when unrecoverable errors
      are detected. */

CHECK_STATUS:
     procedure;
dcl	checking_rew_status bit (1) aligned;
dcl	detailed_status	bit (216);
dcl	detailed_status_array
			(26) bit (8) based;
dcl	have_detail	bit (1) aligned;
dcl	majstat		fixed bin (5);
dcl	mjsdp		ptr;
dcl	ssdp		ptr;
dcl	substat		bit (6) aligned;
dcl	tsx		fixed bin;

	tape_retries = 0;
	tcb.retry_in_progress = NO;
	checking_rew_status = NO;
check_status:
	end_of_file_status, bad_density_status = NO;
	if si.ioi_statusx = tcb.statusx then do;
	     isp = ptr (tcb.wksp, si.ioi_statusx + (size (istat) * tcb.status_idx));
	     tcb.status_idx = mod (tcb.status_idx + 1, tcb.status_count);
	end;
	else isp = ptr (tcb.wksp, si.ioi_statusx);
	io_status_word_ptr = addr (istat.iom_stat);
	if ^istat.completion.st
	then call syserr (CRASH, "bce_save: IO complete, but NO status returned for ^a.", si.tape_set);

	substat = ""b;
	if istat.level = FAULT_INTERRUPT then majstat = SYS_FAULT;
	else if istat.level = SPECIAL_INTERRUPT then do;
	     call syserr (ANNOUNCE, "^a(check_status): Special Interrupt: ^.3b", my_name,
		substr (istat.iom_stat, 1, 36));
	     return;
	end;
	else if istat.time_out then do;
	     call syserr (ANNOUNCE, "^a(check_status): Time-Out on ^a", my_name, tcb.name);
	     if ^supress_error_recovery then goto error_recovery;
	end;
	else if (substr (istat.iom_stat, 1, 36) & STATUS_MASK) = ""b then do;
						/* GOOD status return */
	     if checking_rew_status then goto rew_status_ok;
						/* don't leave yet */
	     tcb.retry_in_progress = NO;
	     return;
	end;
	else if io_status_word.power then do;
	     majstat = POWER_OFF;
	     substat = ""b;
	end;
	else if io_status_word.channel_stat then do;
	     majstat = CHAN_STAT;
	     substat = io_status_word.channel_stat;
	end;
	else if io_status_word.central_stat then do;
	     majstat = CENTRAL_STAT;
	     substat = io_status_word.central_stat;
	end;
	else do;
	     majstat = bin (io_status_word.major, 4);
	     substat = io_status_word.sub;
	end;

	taperap = addrel (tedp, tape_error_data (majstat).interp);

	do tsx = lbound (tape_status_interp_array, 1) to hbound (tape_status_interp_array, 1)
	     while ((substat & tape_status_interp_array (tsx).bitmask) ^= tape_status_interp_array (tsx).bitson);
	end;
	taperp = addr (tape_status_interp_array (tsx));
	mjsdp = addrel (tedp, tape_error_data (majstat).namep);
	ssdp = addrel (tedp, tape_error_interp.namep);
	if sri.debug then do;
	     call syserr (ANNOUNCE, "DEBUG: (^.3b) ^a, ^a on ^a.^/^2-tape_error_interp = ^w", unspec (io_status_word),
		mjsdp -> tape_status_descrip.chr, ssdp -> tape_status_descrip.chr, tcb.name,
		unspec (tape_error_interp));
	     call ioa_ ("^- istat:^-^4( ^12.3b^)", addrel (addr (istat), 0) -> debug_based_block);
	     call ioa_ ("^2-^4( ^12.3b^)", addrel (addr (istat), 4) -> debug_based_block);
	end;

	if ^tcb.eot then tcb.eot = tape_error_interp.end_of_tape;
	end_of_file_status = tape_error_interp.end_of_file;
	bad_density_status = tape_error_interp.bad_density;

/**** The following check is done to find out if the retry of a data alert
      at End of Tape completed properly.  If the istat.offset is less than
      the first buffer, then the chain was terminated prematurely and the
      original IDCW will need to be executed again, to complete the I/O.

      An example of this is when a backspace & erase has to be inserted before
      a write-tape-binary to retry a write error. The hardware will do this
      properly, except when at EOT, in which case it does the backspace &
      erase and returns data alert/end-of-tape status. The program has to
      manually re-issue the write-tape-binary. */

	if tape_error_interp.end_of_tape then do;
	     if tcb.retry_in_progress & istat.offset < bin (tcb.buf_listx, 18) then do;
		call TAPE_CONNECT (bin (si.last_idcwx, 18));
						/* re-issue */
		call WAIT_FOR_STATUS (si.ioi_term_post_buf);
		goto check_status;
	     end;
	     tcb.retry_in_progress = NO;
	end;

	if supress_error_recovery | tape_error_interp.end_of_tape | end_of_file_status | bad_density_status then return;
						/* let the caller handle */

	if tape_retries < tape_error_interp.max_retries then do;
retry_the_io:
	     tcb.retry_in_progress = YES;
	     if (tcb.write_tape & ^tcb.density_set & ^si.written_tape_label & tape_error_interp.backspace) then do;
						/* special case error writing first label record */
		call SET_IOI_POST_BUF (si.ioi_spec_post_buf, WAITING_SPECIAL);
		idcwp = addr (stat_ws.retry_dcw (1));
		unspec (idcw) = DEFAULT_IDCW;
		idcw.command = REWIND;
		idcw.device = bit (bin (tcb.device, 6), 6);
		call TAPE_CONNECT (bin (rel (addr (stat_ws.retry_dcw (1))), 18));
		call WAIT_FOR_STATUS (si.ioi_term_post_buf);
		checking_rew_status = YES;
		goto check_status;			/* see if rewind went ok */
rew_status_ok:
		checking_rew_status = NO;
		call WAIT_FOR_SPECIAL (si.ioi_spec_post_buf);
		if io_post_buffer.state = WAITING_SPECIAL then do;
		     call syserr (ANNOUNCE, "^a(^a): Time-out waiting for special interrupt.", my_name, si.tape_set);
		     goto error_recovery;
		end;

		call TAPE_CONNECT (bin (si.last_idcwx, 18));
						/* now retry the I/O chain */
	     end;
	     else if tape_error_interp.backspace then do;
		idcwp = addr (stat_ws.retry_dcw (1));
		unspec (idcw) = ""b;
		idcw.command = BACKSPACE;
		idcw.device = bit (bin (tcb.device, 6), 6);
		idcw.code = IDCW;
		idcw.control = CONTINUE_NO_MARKER;
		idcw.chan_cmd = NON_DATA_XFER;
		idcw.count = ONE_RECORD;		/* backup 1 record */
		tdcwp = addr (stat_ws.retry_dcw (2));
		if tcb.write_tape then do;		/* WRITing; erase bad spot */
		     idcwp = addr (stat_ws.retry_dcw (2));
		     unspec (idcw) = ""b;
		     idcw.command = ERASE;
		     idcw.device = bit (bin (tcb.device, 6), 6);
		     idcw.code = IDCW;
		     idcw.control = CONTINUE_NO_MARKER;
		     idcw.chan_cmd = NON_DATA_XFER;
		     idcw.count = ONE_RECORD;
		     tdcwp = addr (stat_ws.retry_dcw (3));
		     iob_hold_ptr = iobp;
		     do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx)
			while (rel (iobp) ^= ""b);
			if iob.state = TAPE_BUSY then do;
			     if istat.offset >= bin (rel (addr (iob.idcw_word)), 18)
				& istat.offset <= bin (rel (addr (iob.tdcw_word)), 18)
			     then si.last_idcwx = bit (rel (addr (iob.idcw_word)), 18);
						/* locate BAD buffer to start retry */
			end;
		     end;
		     iobp = iob_hold_ptr;
		end;
		else do;				/* READing; increment auto read retry */
		     idcwp = ptr (tcb.wksp, si.last_idcwx);
		     if tape_retries < MAX_READ_RETRY
		     then idcw.chan_cmd = bit (bin (FIRST_READ_RETRY_CMD + tape_retries, 6), 6);
		     else idcw.chan_cmd = LAST_READ_RETRY_CMD;
		end;
		unspec (tdcw) = ""b;
		tdcw.address = si.last_idcwx;		/* retry previous IO */
		tdcw.type = TDCW;
		tdcw.rel = ON;

		call TAPE_CONNECT (bin (rel (addr (stat_ws.retry_dcw (1))), 18));
	     end;
	     else call TAPE_CONNECT (bin (si.last_idcwx, 18));
	     tape_retries = tape_retries + 1;
	     tcb.retry_count = tcb.retry_count + 1;
	     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	     goto check_status;
	end;
	else if tape_error_interp.expect_special then do; /* wait for special */
	     call SET_IOI_POST_BUF (si.ioi_spec_post_buf, WAITING_SPECIAL);
	     call syserr (ANNOUNCE, "^a(^a): Waiting for special on ^a.", my_name, si.tape_set, tcb.name);
	     call WAIT_FOR_SPECIAL (si.ioi_spec_post_buf);
	     if io_post_buffer.state = WAITING_SPECIAL then do;
		call syserr (ANNOUNCE, "^a(^a): Time-out waiting for special interrupt.", my_name, si.tape_set);
		goto error_recovery;
	     end;
	end;
	else do;					/* Bad news */
	     have_detail = NO;
	     if tape_error_interp.get_detail
	     then call ioi_get_status$detailed_status (tcb.ioi_index, have_detail, detailed_status, code);

	     call syserr (ANNOUNCE, "^a(^a):^[ (Unrecoverable)^;^] ^a, ^a on ^a.", my_name, si.tape_set,
		tcb.retry_in_progress, mjsdp -> tape_status_descrip.chr, ssdp -> tape_status_descrip.chr, tcb.name);
	     if majstat > POWER_OFF then call ioa_ ("^5xstatus: ^.3b", unspec (io_status_word));
	     else if have_detail
	     then call ioa_ ("^5xdetailed status:^13( ^2.4b^)^/^22t^13( ^2.4b^)",
		     addr (detailed_status) -> detailed_status_array);
error_recovery:
	     if tape_error_interp.bad_dev		/* don't try to unload on detach */
	     then tcb.tape_mounted = NO;
	     call TAPE_ERROR_RECOVERY;		/* will only return if Opr want to retry again. */
	     tape_retries = 0;			/* reset counter */
	     goto retry_the_io;
	end;
	tcb.retry_in_progress = NO;
	return;					/* good return */
     end CHECK_STATUS;
%page;
/**** CLEANUP - Procedure to cleanup program on exit.

      NOTE: The SET_PTRS code has been duplicated here so that
      the SET_PTRS procedure can remain QUICK. */

CLEANUP:
     procedure;

	do setx = lbound (set_info, 1) to sri.set_count;

/**** Begin SET_PTRS code */

	     sri.set_index = setx;
	     si_ptr = addr (set_info (setx));
	     info_tape_labelp = si.info_tape_label_ptr;
	     part_arrayp = addr (part_area (setx, 1));
	     partp = si.part_ptr;
	     pv_arrayp = addr (pv_area (setx, 1));
	     pvp = si.pv_ptr;
	     tape_labelp = si.tape_label_ptr;
	     tcb_arrayp = addr (tcb_area (setx, 0));
	     tcbp = si.tcb_ptr;
	     vol_preamblep = si.vol_preamble_ptr;
	     vol_infop = si.vol_info_ptr;

/**** End SET_PTRS code */

	     if tcbp ^= null () then do;
		if tcb.ioi_index ^= 0 then do;
		     if iobp ^= null ()
		     then do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx)
			     while (rel (iobp) ^= ""b);
			do while (iob.state = DISK_BUSY);
			     call bootload_disk_io$test_done (iob.disk_post_buf, code);
			     if code ^= error_table_$not_done then do;
				iob.state = FREE;
				iob.state_time = clock ();
			     end;
			end;
		     end;
		     call DETACH_TAPE;
		end;
	     end;
	     if tape_labelp ^= null () then call release_temp_segment_ (my_name, tape_labelp, code);
	end;

	if disk_post_area_ptr ^= null () then disk_post_area.number = 0;

	if ioi_post_area_ptr ^= null () then ioi_post_area.number = 0;
	if ss_info_ptr ^= null () then ss_info.flags.request_handling_opr_aborts = NO;
	return;
     end CLEANUP;
%page;
/**** DETACH_TAPE - Detach tape device. */

DETACH_TAPE:
     procedure;

	call ioi_assignment$unassign (tcb.ioi_index, code);
	if code ^= 0 then call syserr$error_code (BEEP, code, "^a: Unassigning ^a.^66t***", my_name, tcb.name);
	tcb.attached = NO;
	tcb.ioi_index = 0;
	si.ioi_statusx = -1;
	return;
     end DETACH_TAPE;
%page;
/**** Routine to check if an outstanding disk I/O has completed. Returns
      YES or NO based on the results.

      NOTE: This routine is duplicated in bce_save_util_.pl1 to save having
      to push a stack frame. */

DISK_DATA_READY:
     procedure () returns (bit (1));

	if iob.state = DISK_READY then return (YES);
	call bootload_disk_io$test_done (iob.disk_post_buf, code);
	if code = error_table_$not_done then return (NO);
	if code ^= 0 then do;			/* until something better */
	     call syserr$error_code (BEEP, code, "^a: ^a", my_name, pv.name);
	     call ABORT;
	end;
	iob.state = DISK_READY;
	iob.state_time = clock ();
	return (YES);
     end DISK_DATA_READY;
%page;
/**** Routine to scan the IO buffers for outstanding disk I/O. */

DISK_RUN:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = DISK_BUSY
	     then if OLDEST_BUFFER (iobp, DISK_BUSY) then do;
		     if DISK_DATA_READY ()
		     then if iob.write then call FREE_BUFFER;
						/* free buffer */
		end;
	end;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = DISK_QUEUED
	     then if OLDEST_BUFFER (iobp, DISK_QUEUED) then do;
		     if iob.write
		     then call WRITE_DISK;
		     else call READ_DISK;
		end;
	end;
	return;
     end DISK_RUN;
%page;
/**** Routine to scan the I/O buffers for all non-free ones.  Based on the
      current state of the buffer it is either freed or written to the
      output device (disk or tape).  This routine is called at the end of
      each tape when doing either a save or restore because the buffers
      have to be flushed before the tape device workspace disappears. */

FLUSH_BUFFERS:
     procedure;
dcl	flushed		bit (1);

	flushed = NO;
	do while (^flushed);
	     flushed = YES;				/* until proven otherwise */
	     do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
		if restoring then do;		/* reading tape, writing disk */
		     if iob.state = TAPE_QUEUED then do;/* Not needed */
			call FREE_BUFFER;
			flushed = NO;
		     end;
		     else if iob.state = TAPE_BUSY
		     then if OLDEST_BUFFER (iobp, TAPE_BUSY) then do;
			     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
			     call CHECK_STATUS;
			     if end_of_file_status
			     then iob.state = FREE;	/* not worth keeping */
			     else iob.state = TAPE_READY;
						/* might want to write to disk */
			     iob.state_time = clock ();
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = TAPE_READY
		     then if OLDEST_BUFFER (iobp, TAPE_READY) then do;
			     call QUEUE_DISK_WRITE;
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = DISK_QUEUED
		     then if OLDEST_BUFFER (iobp, DISK_QUEUED) then do;
			     call bootload_disk_io$test_done (iob.disk_post_buf, code);
			     if code = 0 then call WRITE_DISK;
						/* no I/O going on */
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = DISK_BUSY
		     then if OLDEST_BUFFER (iobp, DISK_BUSY) then do;
			     code = -1;
			     do while (code ^= 0);	/* wait for IO to finish */
				call bootload_disk_io$test_done (iob.disk_post_buf, code);
				if code ^= 0 & code ^= error_table_$not_done then do;
						/* until something better */
				     call syserr$error_code (BEEP, code, "^a: ^a", my_name, pv.name);
				     call ABORT;
				end;
			     end;
			     call FREE_BUFFER;
			     flushed = NO;
			end;
			else flushed = NO;
		end;
		else do;				/* reading disk, writing tape */
		     if iob.state = DISK_QUEUED
		     then if OLDEST_BUFFER (iobp, DISK_QUEUED) then do;
			     call bootload_disk_io$test_done (iob.disk_post_buf, code);
			     if code = 0 then call READ_DISK;
						/* no I/O going on */
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = DISK_BUSY
		     then if OLDEST_BUFFER (iobp, DISK_BUSY) then do;
			     code = -1;
			     do while (code ^= 0);	/* wait for IO to finish */
				call bootload_disk_io$test_done (iob.disk_post_buf, code);
				if code ^= 0 & code ^= error_table_$not_done then do;
						/* until something better */
				     call syserr$error_code (BEEP, code, "^a: ^a", my_name, pv.name);
				     call ABORT;
				end;
			     end;
			     iob.state = DISK_READY;
			     iob.state_time = clock ();
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = DISK_READY
		     then if OLDEST_BUFFER (iobp, DISK_READY) then do;
			     call QUEUE_TAPE_WRITE;
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = TAPE_QUEUED
		     then if OLDEST_BUFFER (iobp, TAPE_QUEUED) then do;
			     if ioi_post_area.buffer (si.ioi_term_post_buf).state = IO_COMPLETE then do;
				iob_hold_ptr = iobp;/* check if its OK to issue another I/O */
				do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx)
				     while (rel (iobp) ^= ""b);
				     if iob.state = TAPE_BUSY then do;
						/* nop, last one has not been processed */
					iobp = iob_hold_ptr;
					flushed = NO;
					goto next_iob;
				     end;
				end;
				iobp = iob_hold_ptr;
				if iob.head.rec_in_type = 0 | si.write_eof then do;
						/* switched areas */
				     call ISSUE (WRITE_EOF);
				     si.write_eof = NO;
				end;
				call WRITE_RECORD;
			     end;
			     flushed = NO;
			end;
			else flushed = NO;
		     else if iob.state = TAPE_BUSY
		     then if OLDEST_BUFFER (iobp, TAPE_BUSY) then do;
			     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
			     call CHECK_STATUS;
			     call FREE_OR_REQUEUE_TAPE_IO;
			     flushed = NO;
			end;
			else flushed = NO;
		end;
next_iob:
	     end;
	end;
	return;
     end FLUSH_BUFFERS;
%page;
/**** Small routine to mark an I/O buffer as free.

      NOTE: This routine is duplicated in bce_save_util_.pl1 to save having
      to push a stack frame. */

FREE_BUFFER:
     procedure;

	iob.state = FREE;
	iob.state_time = clock ();
	return;
     end FREE_BUFFER;
%page;
/**** Small routine to either free the IO buffers in a write tape chain
      or re-queue them to be written (unchained) because of a EOT condition. */

FREE_OR_REQUEUE_TAPE_IO:
     procedure;
dcl	iob_eot_state	fixed bin;

	iob_hold_ptr = iobp;
	iob_eot_state = FREE;			/* start by freeing iob at EOT */
	prev_iobp = null ();
	do iobp = iobp repeat ptr (tcb.wksp, iob.next_statex) while (rel (iobp) ^= ""b);
	     if iob.head.end_of_part then part.complete = YES;
						/* This partition saved */
	     if iob.head.end_of_pv then pv.complete = YES;/* PV save complete? */
	     if iob_eot_state = FREE then do;
		tcb.records_written = tcb.records_written + 1;
		if tcb.records_written ^= iob.head.rec_on_tape & ^si.restart_requested then do;
		     call syserr (ANNOUNCE,
			"^a(^a): Incorrect tape sequence number detected.^66t***^/^-was ^d, s/b ^d.  Forcing restart of this tape set.",
			my_name, si.tape_set, iob.head.rec_on_tape, tcb.records_written);
		     si.restart_requested = YES;
		end;
	     end;
	     if tcb.eot then do;
		idcwp = addr (iob.idcw_word);
		idcw.control = NO_CONTINUE_NO_MARKER;	/* break dcw list thread */
		iob.state = iob_eot_state;		/* Free or Re-queue for writing */
		if istat.offset >= bin (rel (addr (iob.idcw_word)), 18)
		     & istat.offset <= bin (rel (addr (iob.tdcw_word)), 18)
		then iob_eot_state = TAPE_QUEUED;	/* requeue all remaining buffers in chain */
		if prev_iobp ^= null () then prev_iobp -> iob.next_statex = 0;
						/* unthread previous IO buffer */
		prev_iobp = iobp;			/* setup for next one */
	     end;
	     else call FREE_BUFFER;
	end;
	iobp = iob_hold_ptr;
	return;
     end FREE_OR_REQUEUE_TAPE_IO;
%page;
/**** Routine to locate a free I/O buffer and mark it as suspended for
      disk I/O.  The caller must have previously called BUFFER_AVAILABLE
      so that the routine does not abort when none can be found.

      NOTE: This routine is duplicated in bce_save_util_.pl1 to save having
      to push a stack frame. */

GET_DISK_BUFFER:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = FREE then do;
		iob.state = DISK_SUSPEND;
		iob.state_time = clock ();
		iob.next_statex = 0;
		si.datap = ptr (tcb.wksp, iob.datax);
		return;
	     end;
	end;
	call syserr (CRASH, "bce_save: Out of disk buffers for ^a.", si.tape_set);
     end GET_DISK_BUFFER;
%page;
/**** Routine to locate a free I/O buffer and mark it as suspended for
      tape I/O.  The caller must have previously called BUFFER_AVAILABLE
      so that the routine does not abort when none can be found. */

GET_TAPE_BUFFER:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = FREE then do;
		iob.state = TAPE_SUSPEND;
		iob.state_time = clock ();
		iob.next_statex = 0;
		si.datap = ptr (tcb.wksp, iob.datax);
		return;
	     end;
	end;
	call syserr (CRASH, "bce_save: Out of tape buffers for ^a.", si.tape_set);
	return;
     end GET_TAPE_BUFFER;
%page;
/**** Routine that is used to issue all non-data transfer commands.  It
      issues the connect and then waits for termination. */

ISSUE:
     procedure (command_to_issue);
dcl	command_to_issue	bit (6) unal;
	call CHECK_ABORT;				/* user wanta quit? */

	stat_ws.idcw = DEFAULT_IDCW;
	idcwp = addr (stat_ws.idcw);
	idcw.command = command_to_issue;
	idcw.device = bit (bin (tcb.device, 6), 6);	/* fill in device# */
	if command_to_issue = REQUEST_STATUS then idcw.count = ""b;
						/* not used for this one. */
	unspec (stat_ws.stat) = ""b;
	if bin (rel (addr (stat_ws.stat)), 18) ^= si.ioi_statusx then do;
	     si.ioi_statusx = bin (rel (addr (stat_ws.stat)), 18);
	     call ioi_set$status (tcb.ioi_index, si.ioi_statusx, 1, code);
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Setting status index for ^a.^66t***", my_name, tcb.name);
		call ABORT;
	     end;
	end;

	call TAPE_CONNECT (bin (rel (addr (stat_ws.idcw)), 18));
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;
	return;
     end ISSUE;
%page;
/**** For all calls to the routine, except for PV_PREAMBLE, iobp &
      si.datap will be pointing at the data read from the tape.  For
      PV_PREAMBLE calls the record is moved to the preamble area and the
      buffer is freed. */

LOCATE_RECORD:
     procedure (p_rec_type);
dcl	p_rec_type	fixed bin parm;

	call GET_TAPE_BUFFER;
	tcb.one_eof = NO;
read_next_record:
	call READ_RECORD;
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;
	if end_of_file_status then do;
	     if tcb.one_eof then do;
		call syserr (ANNOUNCE, "^a(^a): End of Information without detecting TAPE_EOR record.^66t***",
		     my_name, si.tape_set);
		goto tape_end;
	     end;
	     tcb.one_eof = YES;
	     goto read_next_record;
	end;
	tcb.one_eof = NO;
	if tcb.eot then do;
tape_end:
	     call FREE_BUFFER;
	     call NEXT_TAPE_DEVICE;
	     if si.next_tape_number > si.tape_seq_number
	     then si.tape_seq_number = si.next_tape_number;
	     else si.tape_seq_number = si.tape_seq_number + 1;
	     call READ_TAPE_LABEL;
	     call GET_TAPE_BUFFER;
	     goto read_next_record;
	end;
	if ^VALID_REC_HEADER (0) then goto tape_end;	/* bad header patterm */
	if si.tape_set_uid ^= iob.head.tape_set_uid then goto tape_end;
						/* bad UID */

	if iob.head.type ^= p_rec_type then do;
	     if iob.head.type = TAPE_EOR then goto tape_end;
skip_file:
	     call ISSUE (FORWARD_SPACE_FILE);
	     goto read_next_record;
	end;
	iob.state = TAPE_READY;
	iob.state_time = clock ();
	si.tape_rec_count = iob.head.rec_on_tape;	/* start checking from here */
	if p_rec_type = PV_PREAMBLE then do;
	     if si.datap -> label.pv_name ^= pv.name then goto skip_file;
	     vol_preamblep -> page = si.datap -> page;	/* copy label record */
	     call FREE_BUFFER;
	     do volx = lbound (tape_label.vol_array, 1) to tape_label.vol_array_size
		while (tape_label.vol_array (volx).pvname ^= pv.name);
	     end;
	     si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (volx));
	     si.display_pv_record = YES;		/* display # of next record read */
	end;
	return;
     end LOCATE_RECORD;
%page;
/**** This routine is used during a restart to read the label from the
      tape that is to be used as the restart check point.  From the label
      information it can then skip the volumes that need to be skipped and
      locate the starting record of the current volume.  If doing a save
      the operator is asked if the current tape should be rewritten or
      dismounted and another put in its place. */

LOCATE_RESTART_POINT:
     procedure;

	if TAPE_DEVICE_READY () then call UNLOAD_TAPE;	/* force mount request */
lrp_read_tape_label:
	si.tape_seq_number = 0;
	call READ_TAPE_LABEL;			/* read last good tape label */
	si.tape_seq_number = bin (tape_label.tape_number, 17);
						/* start at this # */
	if ^restoring then si.tape_seq_number = si.tape_seq_number - 1;
						/* write_tape_label will add 1 */
	if ^restoring & tape_label.save_time + ONE_WEEK < clock () then do;
	     call syserr (ANNOUNCE, "^a(^a): This tape is older than one week. Tape rejected.^66t***", my_name,
		si.tape_set);
	     call UNLOAD_TAPE;
	     goto lrp_read_tape_label;
	end;
	if restoring then do;
	     do volx = lbound (tape_label.vol_array, 1) to tape_label.vol_array_idx - 1;
						/* skip PVs from earlier tapes */
		do si.pvx = lbound (pv_array, 1) to si.pv_count;
		     if pv_array (si.pvx).name = tape_label.vol_array (volx).pvname then do;
			pv_array (si.pvx).complete = YES;
			do partx = pv_array (si.pvx).part_idx repeat part_array (partx).next_idx while (partx ^= 0);
						/* mark all parts for a pv complete */
			     part_array (partx).complete = YES;
			end;
			goto next_vol_array;
		     end;
		end;
next_vol_array:
	     end;

	     do volx = tape_label.vol_array_idx to tape_label.vol_array_size;
						/* locate first PV to restore */
		do si.pvx = lbound (pv_array, 1) to si.pv_count;
		     if pv_array (si.pvx).name = tape_label.vol_array (volx).pvname then goto found_pv;
						/* start from this PV */
		end;
	     end;
	     do i = lbound (pv_array, 1) to si.pv_count while (pv_array (i).complete);
		call syserr (ANNOUNCE, "^a(^a): Skipping volume ^a on ^a, restore complete.", my_name, si.tape_set,
		     pv_array (i).name, pv_array (i).device);
	     end;
	     call syserr (ANNOUNCE, "^a(^a): ^a complete...", my_name, si.tape_set, my_name);
	     si.complete = YES;			/* must be done.. */
	     return;

found_pv:
	     do i = lbound (pv_array, 1) to si.pv_count while (pv_array (i).complete);
		call syserr (ANNOUNCE, "^a(^a): Skipping volume ^a on ^a, restore complete.", my_name, si.tape_set,
		     pv_array (i).name, pv_array (i).device);
	     end;
	     si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (volx));
	     pv_array (si.pvx).restart.rec_on_pv = vol_info.restart.rec_on_pv;
	     pv_array (si.pvx).restart.rec_in_type = vol_info.restart.rec_in_type;
	     call syserr (ANNOUNCE, "^a(^a): Starting from volume ^a on ^a.", my_name, si.tape_set,
		pv_array (si.pvx).name, pv_array (si.pvx).device);
	end;
	else do;
	     do si.pvx = lbound (pv_array, 1) to si.pv_count while (pv_array (si.pvx).name ^= vol_info.pvname);
	     end;
	     if si.pvx > si.pv_count then do;
		call syserr (ANNOUNCE,
		     "^a(^a): This tape starts with volume ^a,^66t***^/^-which was not defined. Tape rejected.",
		     my_name, si.tape_set, vol_info.pvname);
		call UNLOAD_TAPE;
		goto lrp_read_tape_label;
	     end;
	     do si.pvx = lbound (pv_array, 1) to si.pv_count while (pv_array (si.pvx).name ^= vol_info.pvname);
		pv_array (si.pvx).complete = YES;
		do partx = pv_array (si.pvx).part_idx repeat part_array (partx).next_idx while (partx ^= 0);
						/* mark all parts for a pv complete */
		     part_array (partx).complete = YES;
		end;
		call syserr (ANNOUNCE, "^a(^a): Skipping volume ^a on ^a, save complete.", my_name, si.tape_set,
		     pv_array (si.pvx).name, pv_array (si.pvx).device);
	     end;
	     pv_array (si.pvx).restart.rec_on_pv = vol_info.restart.rec_on_pv;
	     pv_array (si.pvx).restart.rec_in_type = vol_info.restart.rec_in_type;
	     call syserr (ANNOUNCE, "^a(^a): Starting from volume ^a on ^a.", my_name, si.tape_set,
		pv_array (si.pvx).name, pv_array (si.pvx).device);

save_restart_query:
	     call bce_query (opr_input, "^a(^a): Do you want to replace or rewrite tape# ^a on ^a? ", my_name,
		si.tape_set, ltrim (tcb.tape_vol_number, "0"), tcb.name);
	     if opr_input = "replace" | opr_input = "rep" then do;
		call UNLOAD_TAPE;
		return;
	     end;
	     else if opr_input = "rewrite" | opr_input = "rew" then ;
						/* don't have to do anything */
	     else do;
		call ioa_ ("^a(^a): Invalid input ""^a"". Must be ""replace"" or ""rewrite"".", my_name, si.tape_set,
		     opr_input);
		goto save_restart_query;
	     end;
	end;
	call REWIND_TAPE;
	return;
     end LOCATE_RESTART_POINT;
%page;
/**** This routine is for finding the number of the tape that should
      be on the current tape device during a restore. It also has the
      tape label read in. */

LOCATE_TAPE:
     procedure;

	call bce_save_util_$locate_tape_number (srip);
	if si.tape_seq_number = 0 | si.tape_seq_number ^= bin (tcb.tape_vol_number, 17) then do;
						/* different tape? */
	     if tcb.tape_vol_number ^= "" then call NEXT_TAPE_DEVICE;
						/* must seq to next device */
	     if si.tape_seq_number = 0 then si.tape_seq_number = 1;
						/* default to ONE */
	     call READ_TAPE_LABEL;
	end;
	return;
     end LOCATE_TAPE;
%page;
/**** This routine is used to create an I/O buffer with a page of ZEROs
      and fake it out to look as if it came from the tape.  This routine
      is called when a partition needs to be padded or the VTOC cleared. */

MAKE_ZERO_DISK_RECORD:
     procedure;

	call GET_TAPE_BUFFER;
	pv.zrec = pv.zrec + 1;			/* increment relative record# */
	if pv.zero_vtoc then do;
	     iob.head.rec_on_pv = pv.zrec;
	     iob.head.rec_in_type = pv.zrec;
	     call SETUP_REC_HEADER (PV_VTOC);
	end;
	else do;
	     iob.head.rec_on_pv = part.frec + pv.zrec;
	     iob.head.rec_in_type = pv.zrec;
	     iob.head.part_name = part.name;
	     call SETUP_REC_HEADER (PV_PART);
	end;
	unspec (iob.head.flags) = ""b;
	unspec (si.datap -> page) = ""b;		/* zero data */
	iob.state = TAPE_READY;			/* data ready.. */
	iob.state_time = clock ();
	return;
     end MAKE_ZERO_DISK_RECORD;
%page;
/**** This routine is called after it has been found that a tape is not
      mounted on the device.  It requests that a tape be mounted and waits
      until one is mounted.  It will never return unless a tape can be
      mounted. */

MOUNTED_TAPE:
     procedure () returns (bit (1));

mount_message:
	if ^tcb.mount_requested then do;
	     if si.need_info_tape
	     then call syserr (BEEP, "^a(^a): Please mount the ""Info"" tape on ^a.", my_name, si.tape_set, tcb.name);
	     else if si.restart
	     then call syserr (BEEP, "^a(^a): Please mount the ""restart"" tape on ^a.", my_name, si.tape_set, tcb.name)
		     ;
	     else call syserr (BEEP, "^a(^a): Please mount tape# ^d on ^a.", my_name, si.tape_set, si.tape_seq_number,
		     tcb.name);
	end;
	tcb.mount_requested = NO;			/* turn off, for next time. */
spec_wait:
	call SET_IOI_POST_BUF (si.ioi_spec_post_buf, WAITING_SPECIAL);
	call WAIT_FOR_SPECIAL (si.ioi_spec_post_buf);
	if io_post_buffer.state = WAITING_SPECIAL then do;
	     if bce_save_util_$skip_tape_device (srip) then return (NO);
						/* skip to next */
	end;
	if (io_special_status.byte3 & MTH_TO_READY) = "00"b4 then goto spec_wait;
						/* wait for the right one */
	if ^TAPE_DEVICE_READY () then goto mount_message;
	return (YES);
     end MOUNTED_TAPE;
%page;
/**** Routine to detach the current tape device, sequence to the next
      device, attach it through IOI and have the workspace setup. */

NEXT_TAPE_DEVICE:
     procedure;

next_tape_loop:
	if tcb.ioi_index ^= 0 then do;
	     if tcb.tape_mounted then call UNLOAD_TAPE;
	     call DETACH_TAPE;
	end;
	do si.tcbx = si.tcbx + 1 to si.tape_count while (tcb_array (si.tcbx).removed);
	end;
	if si.tcbx > si.tape_count then do;		/* wrap around */
	     do si.tcbx = FIRST_TAPE_DEV_IDX to si.tape_count while (tcb_array (si.tcbx).removed);
	     end;
	     if si.tcbx > si.tape_count then do;
		call syserr (ANNOUNCE, "^a(^a): No usable tape drives left.", my_name, si.tape_set);
		call ABORT;
	     end;
	end;
	si.tcb_ptr, tcbp = addr (tcb_array (si.tcbx));
	call ATTACH_TAPE;
	if ^tcb.attached then goto next_tape_loop;
	call bce_save_util_$init_buffers (srip);
	tcb.eot = NO;
	return;
     end NEXT_TAPE_DEVICE;
%page;
/**** Routine to find the oldest I/O buffer of a given state.  This is
      needed because there can be several buffers with the same state and
      if they are not handled in a First-In/First-Out fashion then
      everything will get very messed up. */

OLDEST_BUFFER:
     procedure (p_bufp, p_buf_state) returns (bit (1));
dcl	oldest_bufp	ptr;
dcl	oldest_time	fixed bin (71);
dcl	p_buf_state	fixed bin;
dcl	p_bufp		ptr;
dcl	temp_bufp		ptr;

	oldest_bufp = null ();
	oldest_time = clock ();
	do temp_bufp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, temp_bufp -> iob.next_bufx)
	     while (rel (temp_bufp) ^= ""b);
	     if temp_bufp -> iob.state = p_buf_state
	     then if temp_bufp -> iob.state_time < oldest_time then do;
		     oldest_bufp = temp_bufp;
		     oldest_time = temp_bufp -> iob.state_time;
		end;
	end;
	if oldest_bufp = null () then return (NO);	/* none found */
	if p_bufp = oldest_bufp
	then return (YES);
	else return (NO);
     end OLDEST_BUFFER;
%page;
/**** Routine to get a free I/O buffer and set it up for doing a disk
      read. */

QUEUE_DISK_READ:
     procedure (p_rec_type, p_recordx, p_rec_in_area, p_part);
dcl	p_rec_type	fixed bin;
dcl	p_recordx		fixed bin (18);
dcl	p_rec_in_area	fixed bin (18);
dcl	p_part		char (4);

	call GET_DISK_BUFFER;
	iob.head.end_of_part = NO;
	if p_rec_type = PV_PART
	then if p_rec_in_area = part.nrec - 1 then do;
		iob.head.end_of_part = YES;
		do vol_info.current_region = lbound (vol_info.region, 1) to vol_info.nregions
		     while (vol_info.region (vol_info.current_region).part_name ^= p_part);
		end;
		vol_info.region (vol_info.current_region).ends_on_tape = si.tape_seq_number;
	     end;
	     else ;
	if p_recordx = si.last_rec then do;
	     iob.end_of_pv = YES;
	     do vol_info.current_region = lbound (vol_info.region, 1) to vol_info.nregions
		while (vol_info.region (vol_info.current_region).part_name ^= "");
	     end;
	     if vol_info.current_region <= vol_info.nregions
	     then vol_info.region (vol_info.current_region).ends_on_tape = si.tape_seq_number;
	     vol_info.current_region = vol_info.nregions;
	end;
	else iob.end_of_pv = NO;
	iob.head.type = p_rec_type;
	iob.head.rec_on_pv = p_recordx;
	iob.head.rec_in_type = p_rec_in_area;
	iob.head.part_name = p_part;
	iob.write = OFF;
	iob.state = DISK_QUEUED;
	iob.state_time = clock ();
	return;
     end QUEUE_DISK_READ;
%page;
/**** Routine to locate an I/O buffer that was just read in from tape and
      queue it to be written out to disk if needed. */

QUEUE_DISK_WRITE:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = TAPE_READY
	     then if OLDEST_BUFFER (iobp, TAPE_READY) then goto found_buf;
	end;
	return;					/* none found */
found_buf:
	if pv.only_part then do;			/* restoring only partition data */
	     if iob.head.type ^= PV_PART then do;
		si.find_start_of_part = YES;
		call FREE_BUFFER;
		return;
	     end;
	     if iob.head.part_name ^= part.name then do;
		do partx = pv.part_idx repeat part_array (partx).next_idx
		     while (partx ^= 0 & iob.head.part_name ^= part_array (partx).name);
		end;
		if partx = 0 then do;		/* not restoring this partition */
		     si.find_start_of_part = YES;
		     call FREE_BUFFER;
		     return;
		end;
		si.part_ptr, partp = addr (part_array (partx));
	     end;
	     if part.complete then do;		/* shouldn't happen, but ... */
		do partx = pv.part_idx repeat part_array (partx).next_idx
		     while (partx ^= 0 & part_array (partx).complete);
		end;
		if partx = 0
		then pv.complete = YES;		/* all partitions restored. */
		else do;				/* else skip this one and find next */
		     call ISSUE (FORWARD_SPACE_FILE);
		     si.find_start_of_part = YES;
		end;
		call FREE_BUFFER;
		return;
	     end;
	     iob.head.rec_on_pv = part.frec + iob.head.rec_in_type;
	     if si.display_pv_record | iob.head.rec_in_type = 0 then do;
		call syserr (ANNOUNCE, "^a(^a): Partition ^a on ^a, record ^d, on tape# ^a (^a)", my_name,
		     si.tape_set, iob.head.part_name, pv.real_name, iob.head.rec_on_pv,
		     ltrim (tape_label.tape_number, "0"), tcb.name);
		si.display_pv_record = NO;
	     end;
	     if iob.head.end_of_part then do;
		if part.lrec > iob.head.rec_on_pv then do;
		     si.need_zero_record = YES;	/* start making zero pad records */
		     pv.zrec = iob.head.rec_in_type;	/* remember last relative rec# */
		     iob.state = DISK_QUEUED;
		     iob.state_time = clock ();
		     iob.write = YES;		/* switch to writing */
		     iob_hold_ptr = iobp;		/* remember current buffer */
		     call QUIESCE_TAPE;		/* don't need/want any more tape data */
		     iobp = iob_hold_ptr;		/* revert back to proper buffer */
		     return;
		end;
		else do;
part_complete:
		     part.complete = YES;
		     do partx = pv.part_idx repeat part_array (partx).next_idx
			while (partx ^= 0 & part_array (partx).complete);
		     end;
		     if partx = 0
		     then pv.complete = YES;		/* all partitions restored. */
		     else si.find_start_of_part = YES;	/* find next part */
		end;
	     end;
	     else if iob.head.rec_on_pv = part.lrec then goto part_complete;
						/* end of part on PV */
	end;
	else do;					/* restoring PV & possibly parts */
	     if iob.head.type ^= PV_VTOC & iob.head.type ^= PV_RECORD & iob.head.type ^= PV_PART then do;
		call FREE_BUFFER;
		return;
	     end;
	     if iob.head.pvid ^= si.pvid_being_restored then do;
		call FREE_BUFFER;
		pv.complete = YES;
		return;
	     end;
	     if iob.head.end_of_pv then pv.complete = YES;
	     else if iob.head.rec_on_pv < pv.restart.rec_on_pv then do;
		call FREE_BUFFER;
		return;
	     end;
	     if iob.head.type = PV_PART then do;
		if pv.part_requested then do;
		     if iob.head.part_name = part.name then goto restore_this_part;
		     do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
			si.part_ptr, partp = addr (part_array (partx));
			if part.name = iob.head.part_name then goto restore_this_part;
		     end;
		end;
		if ^iob.head.end_of_part then do;	/* waste of time if at the end of the area */
		     call QUIESCE_TAPE;		/* discard any pending tape i/o */
		     call ISSUE (FORWARD_SPACE_FILE);	/* skip this part */
		     call ISSUE (BACKSPACE);		/* backup before EOF */
		     call ISSUE (BACKSPACE);		/* backup before last rec in */
						/* part to check flags on next read */
		end;
		else call FREE_BUFFER;
		return;
restore_this_part:
		if si.display_pv_record | iob.head.rec_in_type = 0 then do;
		     call syserr (ANNOUNCE, "^a(^a):^3xPartition ^a on ^a, record ^d, on tape# ^a (^a)", my_name,
			si.tape_set, iob.head.part_name, pv.name, iob.head.rec_on_pv,
			ltrim (tape_label.tape_number, "0"), tcb.name);
		     si.display_pv_record = NO;
		end;
		if iob.head.end_of_part then do;
		     part.complete = YES;
		     if si.pv_record_detected then do;
			do partx = pv.part_idx repeat part_array (partx).next_idx
			     while (partx ^= 0 & part_array (partx).complete);
			end;
			if partx = 0 then pv.complete = YES;
						/* all done. */
		     end;
		end;
	     end;
	     else if iob.head.type = PV_RECORD & ^si.pv_record_detected then si.pv_record_detected = YES;
	     if si.display_pv_record & ^pv.zero_vtoc then do;
		call syserr (ANNOUNCE, "^a(^a): Volume ^a, record ^d, on tape# ^d (^a)", my_name, si.tape_set,
		     pv.name, iob.head.rec_on_pv, ltrim (tape_label.tape_number, "0"), tcb.name);
		si.display_pv_record = NO;
	     end;
	     else if iob.head.type = PV_VTOC & pv.zero_vtoc
	     then if iob.head.rec_on_pv >= vol_preamble.vtoc_size then do;
		     pv.zero_vtoc = NO;
		     si.need_zero_record = NO;
		end;
		else ;
	end;
	iob.state = DISK_QUEUED;
	iob.state_time = clock ();
	iob.write = YES;				/* switch to writing */
	return;
     end QUEUE_DISK_WRITE;
%page;
/**** Routine to get a free I/O buffer and set it up for doing a tape
      read. */

QUEUE_TAPE_READ:
     procedure;

	call GET_TAPE_BUFFER;
	iob.write = OFF;
	iob.state = TAPE_QUEUED;
	iob.state_time = clock ();
	return;
     end QUEUE_TAPE_READ;
%page;
/**** Routine to locate an I/O buffer that was just read in from disk and
      queue it to be written out to tape. */

QUEUE_TAPE_WRITE:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = DISK_READY
	     then if OLDEST_BUFFER (iobp, DISK_READY) then do;
		     iob.state = TAPE_QUEUED;
		     iob.state_time = clock ();
		     iob.write = YES;		/* switch to writing */
		     call SETUP_REC_HEADER ((iob.head.type));
		     return;
		end;
	end;
	return;
     end QUEUE_TAPE_WRITE;
%page;
/**** Routine to scan the I/O buffers for all tape related buffers and
      free the ones that are queued and wait for a busy tape buffer before
      freeing it. */

QUIESCE_TAPE:
     procedure;
dcl	quiescent		bit (1);

	quiescent = NO;
	do while (^quiescent);
	     quiescent = YES;			/* until proven otherwise */
	     do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
		if iob.state = TAPE_QUEUED then do;	/* Not needed */
		     call FREE_BUFFER;
		     quiescent = NO;
		end;
		else if iob.state = TAPE_BUSY then do;
		     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
		     call CHECK_STATUS;
		     call FREE_BUFFER;
		     quiescent = NO;
		end;
		else if iob.state = TAPE_READY then do;
		     call FREE_BUFFER;
		     quiescent = NO;
		end;
	     end;
	end;
	return;
     end QUIESCE_TAPE;
%page;
/**** Routine that take an I/O buffer that has been queued for a disk read
      and asks that it now take place.

      NOTE: This routine is duplicated in bce_save_util_.pl1 to save having
      to push a stack frame. */

READ_DISK:
     procedure;

	iob.state = DISK_BUSY;
	iob.state_time = clock ();
	call bootload_disk_io$queue_read ((pv.pvtx), (iob.head.rec_on_pv), 1, ptr (tcb.wksp, iob.datax),
	     iob.disk_post_buf, code);
	return;
     end READ_DISK;
%page;
/**** Routine that take an I/O buffer that has been queued for a tape read
      and asks that it now take place. */

READ_RECORD:
     procedure;

	idcwp = addr (iob.idcw_word);
	unspec (idcw) = ""b;
	idcw.command = READ_BINARY;
	idcw.device = bit (bin (tcb.device, 6), 6);	/* fill in device# */
	idcw.code = IDCW;
	idcw.chan_cmd = AUTO_READ_RETRY;

	if tcb.statusx ^= si.ioi_statusx then do;
	     si.ioi_statusx = tcb.statusx;
	     tcb.status_idx = 0;
	     call ioi_set$status (tcb.ioi_index, si.ioi_statusx, (tcb.status_count), code);
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Setting status index for ^a.^66t***^/^-", my_name, tcb.name);
		call ABORT;
	     end;
	end;
	iob.state = TAPE_BUSY;
	iob.state_time = clock ();
	if ^tcb.density_set then do;			/* chk if density chaining needed */
	     stat_ws.idcw = DEFAULT_IDCW;
	     idcwp = addr (stat_ws.idcw);
	     idcw.command = tcb.density_command;
	     idcw.device = bit (bin (tcb.device, 6), 6);	/* fill in device# */
	     idcw.control = CONTINUE_NO_MARKER;
	     tdcwp = addr (stat_ws.tdcw);
	     unspec (tdcw) = ""b;
	     tdcw.address = rel (addr (iob.idcw_word));
	     tdcw.type = TDCW;
	     tdcw.rel = ON;
	end;
	call TAPE_CONNECT (bin (rel (idcwp), 18));
	return;
     end READ_RECORD;
%page;
/**** Routine to read the tape label from the current tape device.  It
      requires two reads to get the entire tape label in. */

READ_TAPE_LABEL:
     procedure;
dcl	rtx		fixed bin;

check_tape_state:
	if ^TAPE_DEVICE_READY ()
	then if ^MOUNTED_TAPE () then do;
		if display_info_tape then call ABORT;
		call NEXT_TAPE_DEVICE;
		goto check_tape_state;
	     end;
	     else ;
	tcb.density_set = NO;
	density_idx = hbound (density_commands, 1) + 1;
next_den_idx:
	density_idx = density_idx - 1;
	if density_idx < 1 then do;
	     call syserr (ANNOUNCE, "^a(^a): Unable to set density on ^a.^66t***", my_name, si.tape_set, tcb.name);
	     if display_info_tape then call ABORT;
	     call NEXT_TAPE_DEVICE;
	     goto check_tape_state;
	end;
	call REWIND_TAPE;
	tcb.density_command = density_commands (density_idx);
	tcb.density = current_density (density_idx);
	if (tcb.density & tcb.densities_available) = ""b then goto next_den_idx;
						/* no sense in trying this one */
	call GET_TAPE_BUFFER;
	do rtx = 0 to divide (size (tape_label) + PAGE_SIZE - 1, PAGE_SIZE, 17) - 1;
						/* read label records */
	     call READ_RECORD;			/* read tape record */
	     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	     call CHECK_STATUS;
	     if bad_density_status then do;		/* Bad density, try another */
		call FREE_BUFFER;
		goto next_den_idx;
	     end;
	     else tcb.density_set = YES;
	     if ^VALID_REC_HEADER (TAPE_LABEL) then do;
		call syserr (ANNOUNCE, "^a(^a): Tape on ^a does not contain a valid label.^66t***", my_name,
		     si.tape_set, tcb.name);
		call FREE_BUFFER;
		call UNLOAD_TAPE;
		goto check_tape_state;
	     end;
	     addrel (tape_labelp, rtx * PAGE_SIZE) -> page = si.datap -> page;
						/* copy tape record */
	end;
	if tape_label.version ^= TAPE_LABEL_VERSION_1 & ^display_info_tape then do;
	     call syserr (ANNOUNCE, "^a(^a): Tape on ^a does not contain a supported tape label version.^66t***",
		my_name, si.tape_set, tcb.name);
	     call FREE_BUFFER;
	     call UNLOAD_TAPE;
	     goto check_tape_state;
	end;
	call date_time_ (tape_label.save_time, date_time_string);
	if ^display_info_tape
	then call syserr (ANNOUNCE, "^a(^a): ^[""Info"" tape^s^;Tape# ^a^] on ^a, created ^a", my_name, si.tape_set,
		(tape_label.tape_number = "Info"), ltrim (tape_label.tape_number, "0"), tcb.name, date_time_string);
	if tape_label.tape_set ^= si.tape_set & ^display_info_tape then do;
	     call syserr (ANNOUNCE, "^a(^a): Error, tape on ^a is part of the ""^a"" set.^66t***", my_name, si.tape_set,
		tcb.name, tape_label.tape_set);
	     call FREE_BUFFER;
	     call UNLOAD_TAPE;
	     goto check_tape_state;
	end;
	tcb.tape_vol_number = tape_label.tape_number;
	if si.need_info_tape then do;
	     if tape_label.tape_number ^= "Info" then do; /* wrong tape? */
		call bce_query$yes_no (yes_no,
		     "^a(^a): Expected ""Info"" tape on ^a.^/^-Is the ""Info"" tape available? ", my_name,
		     si.tape_set, tcb.name);
		if yes_no then do;			/* yes, have it mounted */
		     call FREE_BUFFER;
		     call UNLOAD_TAPE;
		     goto check_tape_state;
		end;
	     end;
	     si.tape_set_uid = iob.head.tape_set_uid;	/* remember UID */
	     info_tape_label = tape_label;		/* copy over info */
	     si.need_info_tape = NO;
	     call FREE_BUFFER;
	     if display_info_tape then return;		/* done enough */
	     call NEXT_TAPE_DEVICE;			/* seq to next tape device */
	end;
	else if (restoring | ^si.restart) & iob.head.tape_set_uid ^= si.tape_set_uid then do;
	     call syserr (ANNOUNCE, "^a(^a): Tape on ^a is not part of this set.^66t***", my_name, si.tape_set,
		tcb.name);
	     call FREE_BUFFER;
	     call UNLOAD_TAPE;
	     goto check_tape_state;
	end;
	else if ^restoring & si.restart then do;	/* restarting save, remember UID */
	     si.tape_set_uid = iob.head.tape_set_uid;
	     call FREE_BUFFER;
	end;
	else if restoring & si.tape_seq_number ^= 0 & bin (tape_label.tape_number, 17) ^= si.tape_seq_number then do;
	     call syserr (ANNOUNCE, "^a(^a): Incorrect tape number. Expected tape# ^d.^66t***", my_name, si.tape_set,
		si.tape_seq_number);
	     call FREE_BUFFER;
	     call UNLOAD_TAPE;
	     goto check_tape_state;
	end;
	else call FREE_BUFFER;
	si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (tape_label.vol_array_idx));
	if restoring then call bce_save_util_$premount_check (srip);
	return;
     end READ_TAPE_LABEL;
%page;
/**** Routine that is used during a save to define the type of disk record
      of the current record index.  When saving all of a volume, the partition
      check must be done by looking in the volume preamble. */

RECORD_TYPE:
     procedure (p_recordx) returns (fixed bin);
dcl	p_recordx		fixed bin (18);

	if p_recordx < vol_preamble.vtoc_size then return (PV_VTOC);
	if ^pv.part_requested then return (PV_RECORD);
	if part.pv_name = pv.name
	then					/* for speed check current part */
	     if part.frec <= p_recordx & p_recordx <= part.lrec then return (PV_PART);
	do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
						/* scan all partitions */
	     si.part_ptr, partp = addr (part_array (partx));
	     if part.frec <= p_recordx & p_recordx <= part.lrec then return (PV_PART);
	end;
	return (PV_RECORD);
     end RECORD_TYPE;
%page;
/**** Routine that is used during a restore when a one-record sequence
      error occurs.  This will back up the tape two records and attempt
      to read the missing record. */

RELOCATE_RECORD:
     procedure;

	idcwp = addr (stat_ws.retry_dcw (1));
	unspec (idcw) = ""b;
	idcw.command = BACKSPACE;
	idcw.device = bit (bin (tcb.device, 6), 6);
	idcw.code = IDCW;
	idcw.control = CONTINUE_NO_MARKER;
	idcw.chan_cmd = NON_DATA_XFER;
	idcw.count = TWO_RECORDS;			/* backup 2 records */
	tdcwp = addr (stat_ws.retry_dcw (2));
	unspec (tdcw) = ""b;
	tdcw.address = bit (bin (rel (addr (iob.idcw_word)), 18));
	tdcw.type = TDCW;
	tdcw.rel = ON;

	call TAPE_CONNECT (bin (rel (addr (stat_ws.retry_dcw (1))), 18));
status_wait:
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;
	if end_of_file_status | (si.tape_rec_count > iob.head.rec_on_tape) then do;
	     call READ_RECORD;
	     goto status_wait;
	end;
	if si.tape_rec_count = iob.head.rec_on_tape
	then call syserr (ANNOUNCE, "^a(^a): Relocated tape sequence # ^d.^66t***", my_name, si.tape_set,
		iob.head.rec_on_tape);
	return;
     end RELOCATE_RECORD;
%page;
/**** Main routine that is called during a restore to process the current
      physical volume.  It has been setup to allow it to be called
      repeatedly, so that the caller can sequence from SET to SET.
      Depending on the current volume's restore state defines what section
      of code gets executed.

      The first phase locates the volumes preamble record from the save
      tape and does some partition validation checks if needed.

      The second main phase is used to move the selected data from the
      tape to the disk until complete. */

RESTORE_PV:
     procedure;

	goto restore_state (pv.state);

restore_state (1):
	si.pvid_being_restored = ""b;
	si.display_pv_record = NO;
	si.pv_record_detected = NO;
	call LOCATE_TAPE;
	do volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size
	     while (info_tape_label.vol_array (volx).pvname ^= pv.name);
	end;
	si.vol_info_ptr, vol_infop = addr (info_tape_label.vol_array (volx));
	if si.pvid_being_restored = ""b then si.pvid_being_restored = vol_info.pvid;
	call LOCATE_RECORD (PV_PREAMBLE);
	if pv.part_requested
	then do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
						/* see if part defined */
	     si.part_ptr, partp = addr (part_array (partx));
	     do i = lbound (vol_preamble.parts, 1) to vol_preamble.nparts
		while (vol_preamble.parts (i).part ^= part.name);
	     end;
	     if i > vol_preamble.nparts then do;	/* part not found */
		if part.name ^= ALL_PARTS
		then call syserr (ANNOUNCE,
			"^a(^a): Partition ^a was not defined when ^a was saved.^66t***^/^-Removing from partition list.",
			my_name, si.tape_set, part.name, pv.name);
		part.removed, part.complete = YES;
	     end;
	     else do;				/* copy part info from save tape */
		part.tfrec = vol_preamble.parts (i).frec;
		part.tlrec = vol_preamble.parts (i).frec + vol_preamble.parts (i).nrec - 1;
		part.tnrec = vol_preamble.parts (i).nrec;
	     end;
	end;

	force_tape_run = YES;			/* don't buffer up tape I/O */
	si.need_zero_record = NO;
	if pv.only_part
	then si.find_start_of_part = YES;
	else do;
	     si.find_start_of_part = NO;
	     if pv.restart.rec_on_pv < vol_preamble.vtoc_size
		& vol_preamble.gcos (1) /* saved value of si.last_used_vtoc_record */ < vol_preamble.vtoc_size
	     then do;
		pv.zero_vtoc = YES;
		si.need_zero_record = YES;
		pv.zrec = vol_preamble.gcos (1);
		call syserr (ANNOUNCE, "^a(^a): Clearing unused VTOC region (records ^d - ^d) on ^a.", my_name,
		     si.tape_set, pv.zrec + 1, vol_preamble.vtoc_size, pv.name);
	     end;
	end;
	pv.state = 2;
	return;

restore_state (2):
	if ^pv.complete then do;
	     if BUFFER_AVAILABLE () then do;
		if si.find_start_of_part then do;
		     call FLUSH_BUFFERS;		/* flush any pending I/O */
		     call LOCATE_RECORD (PV_PART);
		     si.find_start_of_part = NO;
		     si.need_zero_record = NO;
		end;
		else if si.need_zero_record then call MAKE_ZERO_DISK_RECORD;
		else call QUEUE_TAPE_READ;		/* queue tape read */
	     end;
	     call TAPE_RUN;
	     call QUEUE_DISK_WRITE;
	     call DISK_RUN;
	end;

	if pv.complete then do;			/* will be set by QUEUE_DISK_WRITE */
	     call FLUSH_BUFFERS;
	     if pv.all_parts then call ZERO_PARTS_NOT_RESTORED;
	     call syserr (ANNOUNCE, "^a(^a): Restore of volume ^a on ^a complete.", my_name, si.tape_set, pv.real_name,
		pv.device);
	end;
	return;
     end RESTORE_PV;
%page;
/**** Routine to rewind the tape on the current device. */

REWIND_TAPE:
     procedure;

	call SET_IOI_POST_BUF (si.ioi_spec_post_buf, WAITING_SPECIAL);
	call ISSUE (REWIND);
	call WAIT_FOR_SPECIAL (si.ioi_spec_post_buf);
	if tcb.write_tape then tcb.density_set = NO;	/* force denisty to be reset during save */
	return;
     end REWIND_TAPE;
%page;
/**** Main routine that is called during a save to process the current
      physical volume.  It has been setup to allow it to be called
      repeatedly, so that the caller can sequence from SET to SET.
      Depending on the current volume's save state defines what section of
      code gets executed.

      The first phase sets up the volume preamble, reads in the vol_map
      and sets up the internal bit_map.

      The second main phase is used to move the selected data from the
      disk to the tape until complete.  It also initiates the calls to
      have the tape label and volume preamble written when needed. */

SAVE_PV:
     procedure;

	goto save_state (pv.state);

save_state (1):
	do volx = lbound (tape_label.vol_array, 1) to tape_label.vol_array_size
	     while (tape_label.vol_array (volx).pvname ^= pv.name);
	end;
	si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (volx));
	bit_map = ""b;				/* Turn OFF all bits */
	bit_map = ^bit_map;				/* Now turn them ON */
	call GET_DISK_BUFFER;
	iob.head.rec_on_pv = LABEL_ADDR;
	call READ_DISK;				/* read PV label */
	do while (^DISK_DATA_READY ());
	end;
	vol_preamblep -> page = si.datap -> page;
	call FREE_BUFFER;
	if pv.all
	then si.last_used_vtoc_record = vol_preamble.vtoc_size;
	else si.last_used_vtoc_record = bce_save_util_$last_vtoc_used (srip);
	vol_preamble.gcos (1) = si.last_used_vtoc_record; /* save in an unused spot for later use by restore */
	call GET_DISK_BUFFER;
	do i = 0 to divide (size (vol_map) + PAGE_SIZE - 1, PAGE_SIZE, 17) - 1;
						/* read vol_map records */
	     iob.head.rec_on_pv = VOLMAP_ADDR + i;
	     call READ_DISK;
	     do while (^DISK_DATA_READY ());
	     end;
	     addrel (si.vol_map_ptr, i * PAGE_SIZE) -> page = si.datap -> page;
	end;
	vol_mapp = si.vol_map_ptr;
	call FREE_BUFFER;
	if pv.all then do;				/* save all of pv */
	     substr (bit_map, 1, vol_preamble.vol_size) = OFF;
	     do i = lbound (vol_preamble.parts, 1) to vol_preamble.nparts;
						/* only save requested partitions */
		if pv.part_requested
		then do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
		     if part_array (partx).name = vol_preamble.parts (i).part then goto this_part_ok;
		end;
		substr (bit_map, vol_preamble.parts (i).frec + 1, vol_preamble.parts (i).nrec) =
		     ^(substr (bit_map, vol_preamble.parts (i).frec + 1, vol_preamble.parts (i).nrec));
						/* turn bits back ON */
this_part_ok:
	     end;
	end;
	else do;
	     if ^pv.only_part then do;
		substr (bit_map, 1, si.last_used_vtoc_record + 1) = OFF;
						/* save all records upto the last used VTOC record */
		do i = lbound (vol_map.bit_map, 1) to vol_map.bit_map_n_words;
						/* copy/pack vol_map.bit_map */
		     vol_map_bits_to_move = min (vol_map.n_rec - ((i - 1) * VTOCES_PER_WORD), VTOCES_PER_WORD);
		     substr (bit_map, (i - 1) * VTOCES_PER_WORD + vol_map.base_add + 1, vol_map_bits_to_move) =
			substr (vol_map.bit_map (i), 2, vol_map_bits_to_move);
		end;
	     end;
	     if pv.part_requested
	     then do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
		si.part_ptr, partp = addr (part_array (partx));
		substr (bit_map, part.frec + 1, part.nrec) = OFF;
	     end;
	end;

	si.first_rec = find_bit_$first_off (substr (bit_map, 1, vol_preamble.vol_size)) - 1;
	si.last_rec = find_bit_$last_off (substr (bit_map, 1, vol_preamble.vol_size)) - 1;
	if si.first_rec < 0 | si.last_rec < 0
	then call syserr (CRASH, "bce_save: Internal bit map for ^a (^a) contains no in use pages.", pv.name,
		si.tape_set);
	if pv.restart.rec_on_pv > si.first_rec then do;	/* save was restarted */
	     if pv.restart.rec_on_pv > si.last_rec then do;
		pv.complete = YES;
		return;
	     end;
	     si.first_rec = pv.restart.rec_on_pv;
	     si.current_rec_in_area = pv.restart.rec_in_type - 1;
						/* save loop will increment */
	     si.old_rec_type = RECORD_TYPE (pv.restart.rec_on_pv);
	     if si.old_rec_type = PV_PART then si.old_part_name = part.name;
	end;
	else do;
	     si.old_rec_type = -1;
	     si.current_rec_in_area = -1;
	end;

	force_tape_run = NO;
	si.written_preamble = NO;
	si.write_eof = NO;
	si.previous_rec, si.recordx = si.first_rec - 1;
	pv.state = 2;
	return;

save_state (2):
	if ^pv.complete then do;
	     if ^si.written_tape_label then call WRITE_TAPE_LABEL;
	     if BUFFER_AVAILABLE () then do;		/* free buffer */
		si.recordx =
		     find_bit_$first_off (substr (bit_map, si.recordx + 2, (si.last_rec + 1) - (si.recordx + 1)))
		     + si.recordx;
		if si.recordx > si.previous_rec then do;/* only true when OFF bit found */
		     si.previous_rec, vol_info.restart.rec_on_pv = si.recordx;
		     si.rec_type = RECORD_TYPE (si.recordx);
		     if si.old_rec_type ^= si.rec_type then do;
						/* switched disk areas  */
			si.old_rec_type = si.rec_type;
			if si.rec_type = PV_PART then si.old_part_name = part.name;
			si.current_rec_in_area = 0;
			if si.rec_type ^= PV_RECORD then do;
						/* locate current region */
			     if si.rec_type = PV_VTOC
			     then do vol_info.current_region = lbound (vol_info.region, 1)
				     to vol_info.nregions
				     while (vol_info.region (vol_info.current_region).part_name ^= "");
			     end;
			     else if si.rec_type = PV_PART
			     then do vol_info.current_region = lbound (vol_info.region, 1)
				     to vol_info.nregions
				     while (vol_info.region (vol_info.current_region).part_name
				     ^= si.old_part_name);
			     end;
			     vol_info.region (vol_info.current_region).begins_on_tape = si.tape_seq_number;
			end;
		     end;
		     else if si.rec_type = PV_PART & (si.old_part_name ^= part.name) then do;
						/* check for part switching */
			si.old_part_name = part.name;
			si.current_rec_in_area = 0;
			do vol_info.current_region = lbound (vol_info.region, 1) to vol_info.nregions
			     while (vol_info.region (vol_info.current_region).part_name ^= si.old_part_name);
			end;
			vol_info.region (vol_info.current_region).begins_on_tape = si.tape_seq_number;
		     end;
		     else si.current_rec_in_area = si.current_rec_in_area + 1;
		     call QUEUE_DISK_READ (si.rec_type, si.recordx, si.current_rec_in_area, si.old_part_name);
						/* queue read */
		     force_tape_run = NO;		/* buffer tape I/O */
		end;
		else force_tape_run = YES;		/* at end of PV, force writing of queued buffers */
	     end;
	     if ^si.written_preamble then call WRITE_PREAMBLE;
	     call DISK_RUN;
	     call QUEUE_TAPE_WRITE;
	     call TAPE_RUN;
	end;

	if pv.complete
	then					/* will be set by TAPE_RUN */
	     call FLUSH_BUFFERS;			/* write out all outstanding buffers */
	return;
     end SAVE_PV;
%page;
/**** Routine to setup the main pointers to the external data segments and
      get a temp segment for holding the tape label, volume preamble,
      vol_map and internal bit_map during a save or tape label, volume
      preamble and "Info" tape label during a restore.  The program uses
      9 pages, the layout of the temp segment is as follows (in octal):

      *        -- SAVE --                         -- RESTORE --
      * start  length  page  contents      start  length  page  contents
      * -----  ------  ----  --------      -----  ------  ----  --------
      *     0    4000   1-2  tape_label        0    4000   1-2  tape_label
      *  4000    2000     3  vol_preamble   4000    2000     3  vol_preamble
      *  6000    6000   4-6  vol_map        6000    4000   4-5  info_tape_label
      * 14000    6000   7-9  bit_map
*/

SETUP:
     procedure;

	pvtp = addr (pvt$);
	if pvtp = null () then do;
	     call syserr$error_code (BEEP, error_table_$seg_not_found, "^a: pvt.", my_name);
	     call ABORT;
	end;
	sri.pvt_array_ptr, pvt_arrayp = addr (pvt.array);
	tedp = addr (tape_error_data$);
	if tedp = null () then do;
	     call syserr$error_code (BEEP, error_table_$seg_not_found, "^a: tape_error_data.", my_name);
	     call ABORT;
	end;

	disk_post_area_ptr = addr (bootload_disk_post_seg$);
	if disk_post_area_ptr = null () then do;
	     call syserr$error_code (BEEP, error_table_$seg_not_found, "^a: bootload_disk_post_seg.", my_name);
	     call ABORT;
	end;
	disk_post_area.number = sri.set_count * MAX_BUFFERS;
						/* one for each IOB per set */
	unspec (disk_post_area.posted (*)) = ""b;

	ioi_post_area_ptr = addr (bce_ioi_post_seg$);
	if ioi_post_area_ptr = null () then do;
	     call syserr$error_code (BEEP, error_table_$seg_not_found, "^a: bce_ioi_post_seg.", my_name);
	     call ABORT;
	end;
	unspec (ioi_post_area) = ""b;
	ioi_post_area.number = 2 * sri.set_count;	/* need two per set */
	do setx = lbound (set_info, 1) to sri.set_count;
	     sri.set_index = setx;
	     si_ptr = addr (set_info (setx));
	     si.first_disk_post_buf = ((setx - 1) * MAX_BUFFERS) + 1;
						/* first one for this set */
	     si.ioi_term_post_buf = (setx * 2) - 1;	/* one for terminates */
	     si.ioi_spec_post_buf = (setx * 2);		/* one for specials */
	     call get_temp_segment_ (my_name, tape_labelp, code);
	     si.tape_label_ptr = tape_labelp;
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Getting tape label temp segment.", my_name);
		call ABORT;
	     end;
	     si.vol_preamble_ptr, vol_preamblep = addrel (tape_labelp, size (tape_label));
	     if restoring then do;
		si.info_tape_label_ptr, info_tape_labelp = addrel (vol_preamblep, size (label));
		si.vol_map_ptr = null ();
		si.bit_map_ptr = null ();
	     end;
	     else do;
		si.vol_map_ptr = addrel (vol_preamblep, size (label));
		si.bit_map_ptr = addrel (si.vol_map_ptr, size (vol_map));
		si.info_tape_label_ptr, info_tape_labelp = null ();
	     end;
	end;
	return;
     end SETUP;
%page;
/**** Routine to setup the tape record header in the current I/O buffer. */

SETUP_REC_HEADER:
     procedure (p_header_type);
dcl	p_header_type	fixed bin parm;

	iob.head.c1 = C1_PATTERN;
	iob.head.type = p_header_type;
	if p_header_type = TAPE_EOR & si.complete then iob.head.end_of_set = YES;
	if ^si.need_zero_record then si.tape_rec_count = si.tape_rec_count + 1;
	iob.head.rec_on_tape = si.tape_rec_count;
	if p_header_type = TAPE_LABEL | p_header_type = TAPE_EOR then do;
	     iob.head.pvid = ""b;
	     iob.head.rec_on_pv = 0;
	     iob.head.part_name = "";
	end;
	else do;
	     iob.head.pvid = vol_preamble.pvid;
	     if p_header_type ^= PV_PART then iob.head.part_name = "";
	end;
	iob.head.tape_set_uid = si.tape_set_uid;	/* set unique ID */
	return;
     end SETUP_REC_HEADER;
%page;
/**** Routine that is called during the normal program startup or when
      restarting a SET while others are active.  It initiates calls to
      locate a restart point if restarting, has the tape label read if
      doing a restore and has each of the volume labels read from this
      SET. */

SETUP_SET:
     procedure;

	si.tape_seq_number = 0;
	if si.need_info_tape then do;
	     call READ_TAPE_LABEL;			/* read "Info" tape */
	     call bce_save_util_$sort_pv_list (srip);
	end;
	if si.restart then do;
	     call LOCATE_RESTART_POINT;		/* find starting point */
	     if si.complete then return;		/* none left to restart */
	end;

	if ^restoring then do;			/* doing save */
	     if ^si.restart then do;
		unspec (tape_label) = ""b;
		tape_label.version = TAPE_LABEL_VERSION_1;
		tape_label.title = TAPE_LABEL_TITLE;
		tape_label.tape_set = si.tape_set;
		fb71 = clock ();
		si.tape_set_uid = substr (unspec (fb71), 36, 36);
	     end;
	     tape_label.save_time = 0;
	     tape_label.tapes_in_set = 0;
	     si.written_tape_label = NO;
	end;

	do si.pvx = lbound (pv_array, 1) to si.pv_count;	/* read each PV label */
	     call CHECK_ABORT;			/* user wanta quit? */
	     si.pv_ptr, pvp = addr (pv_array (si.pvx));
	     if ^pv.complete then do;
		if restoring & pv.all_parts then call bce_save_util_$setup_all_parts (srip);
		if ^pv.removed then do;
		     pv.state = 1;
		     call bce_save_util_$read_pv_label (srip);
		end;
	     end;
	end;
	return;
     end SETUP_SET;
%page;
/**** This procedure is responsible for finding out what densities and
      speed the desired device runs.  This is done by requesting a device
      survey of all the devices in the string, then locating the info for
      the desired device.  If the write flag is ON, then the requested
      density must be one of the available densities.  On non-fips
      subsystems it is necessary to attach the tape controller and issue
      the survey to it. */

SET_DEVICE_OPTIONS:
     procedure;
dcl	controller_attached bit (1);
dcl	tcb_to_survey_ptr	ptr;

	tcb.surveyed = NO;
	tcb_to_survey_ptr = tcbp;			/* remember in case of switch */
	if ^tcb.fips then do;			/* must do the survey to the Controller */
	     tcb_array (0) = tcb;
	     si.tcb_ptr, tcbp = addr (tcb_array (0));
	     tcb.name = substr (tcb.name, 1, 5) || "00";
	     tcb.device = 0;
	     call bce_save_util_$ioi_attach (srip);
	     controller_attached = YES;
	end;
	else controller_attached = NO;
	unspec (survey_ws) = ""b;			/* clean slate */
	survey_ws.idcw = SURVEY_IDCW;			/* Set up survey_devices tape command. */
	idcwp = addr (survey_ws.idcw);
	idcw.device = bit (bin (tcb.device, 6), 6);

	dcwp = addr (survey_ws.dcw);
	dcw.address = rel (addr (survey_ws.data));	/* Put survey_device info in workspace data. */
	dcw.tally = bit (bin (DEV_SURVEY_DATA_SIZE, 12), 12);
						/* Should return 8 words at most. */

	if bin (rel (addr (survey_ws.stat)), 18) ^= si.ioi_statusx then do;
	     si.ioi_statusx = bin (rel (addr (survey_ws.stat)), 18);
	     call ioi_set$status (tcb.ioi_index, si.ioi_statusx, 1, code);
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Setting status index for ^a.^66t***^/^-", my_name, tcb.name);
		return;
	     end;
	end;

	call TAPE_CONNECT (bin (rel (addr (survey_ws.idcw)), 18));
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;

	call bce_save_util_$scan_survey_data (srip, tcb_to_survey_ptr);
	if controller_attached then do;
	     call ioi_assignment$unassign (tcb.ioi_index, code);
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Unassigning ^a.^66t***^/^-", my_name, tcb.name);
		call ABORT;
	     end;
	     si.tcb_ptr, tcbp = addr (tcb_array (si.tcbx));
	     yes_no = TAPE_DEVICE_USABLE ();		/* issue an IO so that IOI will wire the device workspace */
	     controller_attached = NO;
	     si.ioi_statusx = -1;
	end;
	return;
     end SET_DEVICE_OPTIONS;
%page;
/**** Routine to setup an IOI post buffer with a given state and event
      channel. */

SET_IOI_POST_BUF:
     procedure (buf_num, buf_state);
dcl	buf_num		fixed bin parm;
dcl	buf_state		fixed bin parm;

	io_post_buffer_ptr = addr (ioi_post_area.buffer (buf_num));
	unspec (io_post_buffer) = ""b;
	io_post_buffer.ev_chn = tcb.ioi_ev_chn;
	io_post_buffer.state = buf_state;
	return;
     end SET_IOI_POST_BUF;
%page;
/**** Routine to set the automatic pointers to the values saved in
      the per-set ("si") structure. */

SET_PTRS:
     procedure;

	sri.set_index = setx;
	si_ptr = addr (set_info (setx));
	info_tape_labelp = si.info_tape_label_ptr;
	part_arrayp = addr (part_area (setx, 1));
	partp = si.part_ptr;
	pv_arrayp = addr (pv_area (setx, 1));
	pvp = si.pv_ptr;
	tape_labelp = si.tape_label_ptr;
	tcb_arrayp = addr (tcb_area (setx, 0));
	tcbp = si.tcb_ptr;
	vol_preamblep = si.vol_preamble_ptr;
	vol_infop = si.vol_info_ptr;
	return;
     end SET_PTRS;
%page;
/**** This procedure sets up an entry in the bce_ioi_post_seg and requests
      IOI to issue the connect to the tape. */

TAPE_CONNECT:
     procedure (idcw_offset);
dcl	idcw_offset	fixed bin (18);

	call SET_IOI_POST_BUF (si.ioi_term_post_buf, IO_OUTSTANDING);
	call ioi_connect (tcb.ioi_index, idcw_offset, code);
	if code ^= 0
	then call syserr$error_code (CRASH, code, "bce_save: Error issuing tape connect for ^a (^a).", tcb.name,
		si.tape_set);
	if ^tcb.retry_in_progress then si.last_idcwx = bit (idcw_offset, 18);
	return;
     end TAPE_CONNECT;
%page;
/**** Routine to verify that a tape is mounted on the current device. */

TAPE_DEVICE_READY:
     procedure () returns (bit (1));

	if ^TAPE_DEVICE_USABLE () then return (NO);
	if io_status_word.major = DEV_READY then do;
	     tcb.tape_mounted = YES;
	     tcb.write_protected = ((io_status_word.sub & DEV_WRITE_PROTECT_MASK) = DEV_WRITE_PROTECTED);
						/* write protect bit on? */
	     return (YES);
	end;
	return (NO);
     end TAPE_DEVICE_READY;
%page;
/**** Routine that is used to verify that the current tape device is
      capable of accepting I/O request.  This is done by requesting the
      current status of the device.  Normal error recovery is disabled to
      allow this routine a chance to handle it. */

TAPE_DEVICE_USABLE:
     procedure () returns (bit (1));

	supress_error_recovery = YES;
	call ISSUE (REQUEST_STATUS);
	supress_error_recovery = NO;
	if istat.level ^= TERMINATE_INTERRUPT then return (NO);
	if io_status_word.power then return (NO);
	if (substr (istat.iom_stat, 1, 36) & STATUS_MASK) = ""b then return (YES);
	if io_status_word.major = DEV_ATTENTION then do;
	     if io_status_word.sub = DEV_STANDBY
	     then return (YES);
	     else return (NO);
	end;
	return (NO);
     end TAPE_DEVICE_USABLE;
%page;
/**** Routine that is called to handle unrecoverable tape I/O errors.  The
      operator is given several possible selections to chose from. */

TAPE_ERROR_RECOVERY:
     procedure;
dcl	retry_allowed	bit (1);

	retry_allowed = (^tcb.write_tape & tape_error_interp.max_retries > 0)
						/* retryable errors or restore */
	     | (tcb.write_tape & ^tcb.density_set & ^si.written_tape_label);
						/* first record of tape label on save */
opr_query:
	call bce_query (opr_input, "^a: Action: ", my_name);
	if opr_input = "abort" then call ABORT;
	else if opr_input = "retry" | opr_input = "r" then do;
	     if ^retry_allowed then do;
		call ioa_ ("^a(^a): This error is non-retryable..", my_name, si.tape_set);
		goto opr_query;
	     end;
	     return;				/* CHECK_STATUS will retry the error */
	end;
	else if opr_input = "skip" | opr_input = "s" then do;
	     if tcb.write_tape | ^tape_error_interp.backspace then do;
		call ioa_ ("^a(^a): skip only valid for data alerts during a restore..", my_name, si.tape_set);
		goto opr_query;
	     end;
	     call FREE_BUFFER;			/* give back the buffer */
	     goto NEXT_SET;				/* back to main loop */
	end;
	else if opr_input = "stop_set" | opr_input = "stop" then do;
	     call syserr (ANNOUNCE, "^a: Stopping ^a of set ""^a"".", my_name, my_name, si.tape_set);
	     si.complete = YES;			/* abort by marking complete */
	     goto NEXT_SET;
	end;
	else if opr_input = "remove_device_from_set" | opr_input = "remove" then do;
	     if si.usable_tape_devices = 1 then do;
		call ioa_ ("^a(^a): Unable to remove ^a. This is the last device.", my_name, si.tape_set, tcb.name);
		goto opr_query;
	     end;
	     goto REMOVE_N_RESTART;
	end;
	else if opr_input = "restart_set" | opr_input = "restart" | opr_input = "rt" then goto RESTART;
						/* non-local */
	else if opr_input = "help" | opr_input = "?" then do;
	     call ioa_ ("Valid inputs are:
abort^21t- Abort entire ^a.", my_name);
	     if retry_allowed then call ioa_ ("retry, r^21t- Go back through retry loop again.");
	     if ^tcb.write_tape & tape_error_interp.backspace
	     then call ioa_ ("skip, s^21t- Skip this record and try next.");
	     call ioa_ ("stop_set, stop^21t- Abort ^a of just this set.
restart_set, restart, rt^/^21t- Restart ^a, using this device.
remove_device_from_set, remove
^21t- Remove tape device, restart ^a using next device.", my_name, my_name, my_name);
	     goto opr_query;
	end;
	else do;
	     call ioa_ ("Invalid input ""^a"". Type ""help"" or ""?"" for valid inputs.", opr_input);
	     goto opr_query;
	end;
     end TAPE_ERROR_RECOVERY;
%page;
/**** Routine that scans the I/O buffers either looking for buffers that
      were busy and now complete or if none are busy looking for ones that
      are queued so that it can request that they be initiated.  This
      routine also manages the end of tape processing. */

TAPE_RUN:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = TAPE_BUSY
	     then if OLDEST_BUFFER (iobp, TAPE_BUSY) then do;
		     if ioi_post_area.buffer (si.ioi_term_post_buf).state ^= IO_COMPLETE then return;
		     call CHECK_STATUS;
		     if iob.write then do;
			call FREE_OR_REQUEUE_TAPE_IO;
			if tcb.eot then do;		/* skip to next tape */
			     call FLUSH_BUFFERS;	/* write out all outstanding buffers */
			     call WRITE_TAPE_EOR;
			     call NEXT_TAPE_DEVICE;
			     si.written_tape_label = NO;
			     si.written_preamble = NO;
			     return;
			end;
		     end;
		     else do;
			if end_of_file_status then do;/* hit EOF */
			     if tcb.one_eof then do;
				call syserr (ANNOUNCE,
				     "^a(^a): End of Information without detecting TAPE_EOR record.^66t***",
				     my_name, si.tape_set);
				goto end_of_tape;
			     end;
			     tcb.one_eof = YES;
			     call READ_RECORD;
			     return;
			end;
			tcb.one_eof = NO;
			if tcb.eot then do;
end_of_tape:
			     call FLUSH_BUFFERS;
			     call NEXT_TAPE_DEVICE;
			     if si.next_tape_number > si.tape_seq_number
			     then si.tape_seq_number = si.next_tape_number;
			     else si.tape_seq_number = si.tape_seq_number + 1;
			     call READ_TAPE_LABEL;
			     call LOCATE_RECORD (PV_PREAMBLE);
			     call GET_TAPE_BUFFER;
			     call READ_RECORD;
			     return;
			end;
			if ^VALID_REC_HEADER (0) | iob.head.tape_set_uid ^= si.tape_set_uid then do;
			     call syserr (ANNOUNCE, "^a(^a): Abnormal tape termination of tape# ^a on ^a.^66t***",
				my_name, si.tape_set, ltrim (tcb.tape_vol_number, "0"), tcb.name);
			     goto end_of_tape;
			end;
			si.tape_rec_count = si.tape_rec_count + 1;
			if si.tape_rec_count ^= iob.head.rec_on_tape then do;
			     call syserr (ANNOUNCE,
				"^a(^a): Record sequence error on tape# ^a (^a),^66t***^/^-should be record # ^d, was record # ^d.",
				my_name, si.tape_set, ltrim (tcb.tape_vol_number, "0"), tcb.name,
				si.tape_rec_count, iob.head.rec_on_tape);
			     if si.tape_rec_count + 1 = iob.head.rec_on_tape then call RELOCATE_RECORD;
			     if si.tape_rec_count ^= iob.head.rec_on_tape then do;
				call syserr (ANNOUNCE, "^a(^a): Adjusting tape sequence # to ^d.^66t***", my_name,
				     si.tape_set, iob.head.rec_on_tape);
				si.tape_rec_count = iob.head.rec_on_tape;
						/* readjust.. */
			     end;
			end;
			if iob.head.type = TAPE_EOR then goto end_of_tape;
			iob.state = TAPE_READY;
			iob.state_time = clock ();
		     end;
		     goto end_tape_busy_loop;		/* no need to loop any longer */
		end;
	end;
end_tape_busy_loop:
	if ^force_tape_run
	then if BUFFER_COUNT (TAPE_QUEUED) < QUEUE_THRESHOLD then return;
						/* if buffering, don't continue until N buffers are queued */

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = TAPE_QUEUED
	     then if OLDEST_BUFFER (iobp, TAPE_QUEUED) then do;
		     if iob.write then do;
			if iob.head.rec_in_type = 0 | si.write_eof then do;
						/* switched areas */
			     call ISSUE (WRITE_EOF);
			     si.write_eof = NO;
			end;
			call WRITE_RECORD;
		     end;
		     else call READ_RECORD;
		     return;
		end;
	end;
	return;
     end TAPE_RUN;
%page;
/**** Routine to unload the tape from the current device.  If any errors
      occured while the tape was mounted it displays this info to the
      operator. */

UNLOAD_TAPE:
     procedure;

	if ^display_info_tape
	then call syserr (ANNOUNCE,
		"^a(^a): Unloading ^[^[""Info"" tape^s^;tape# ^a^] from ^;^2s^]^a^[, ^d records^[ (^d errors)^;^s^]^;^s^[ (^d errors)^;^s^]^]",
		my_name, si.tape_set, (tcb.tape_vol_number ^= ""), (tcb.tape_vol_number = "Info"),
		ltrim (tcb.tape_vol_number, "0"), tcb.name, (tcb.write_tape & (si.tape_rec_count > 0)),
		si.tape_rec_count, (tcb.retry_count > 0), tcb.retry_count);
	call SET_IOI_POST_BUF (si.ioi_spec_post_buf, WAITING_SPECIAL);
						/* setup to handle special, but don't wait */
	supress_error_recovery = YES;			/* don't worry about errors */
	call ISSUE (UNLOAD);
	supress_error_recovery = NO;
	tcb.tape_mounted = NO;
	tcb.density_set = NO;
	tcb.tape_vol_number = "";
	return;
     end UNLOAD_TAPE;
%page;
/**** Routine to validate each record header when it is read from the
      tape.  It does this by checking the the header constant and possibly
      checking the record type if requested. */

VALID_REC_HEADER:
     procedure (p_header_type) returns (bit (1));
dcl	p_header_type	fixed bin parm;

	if iob.head.c1 ^= C1_PATTERN then return (BAD);
	if p_header_type ^= 0
	then if iob.head.type ^= p_header_type then return (BAD);
	return (GOOD);
     end VALID_REC_HEADER;
%page;
/**** Routine to wait for a special interrupt from a tape device for upto
      two minutes.  After this time it gives up and the caller is required
      to check to see if the special arrived or not. */

WAIT_FOR_SPECIAL:
     procedure (buf_num);
dcl	TWO_MINUTES	fixed bin (71) int static options (constant) init (120000000);
dcl	buf_num		fixed bin parm;
dcl	time_to_wait	fixed bin (71);

	time_to_wait = clock () + TWO_MINUTES;
	io_post_buffer_ptr = addr (ioi_post_area.buffer (buf_num));
	do while (io_post_buffer.state ^= SPECIAL_ARRIVED);
	     if clock () > time_to_wait then do;	/* time-out */
		if sri.debug then call syserr (ANNOUNCE, "DEBUG: Timeout waiting for special interrupt.");
		return;
	     end;
	     call CHECK_ABORT;			/* operator interrupt? */
	end;
	io_special_status_ptr = addr (addr (io_post_buffer.message) -> imess.status);
	if sri.debug
	then call syserr (ANNOUNCE, "DEBUG: special interrupt (^12.3b) for ^a.",
		unspec (addr (io_post_buffer.message) -> imess.status), tcb.name);
	return;
     end WAIT_FOR_SPECIAL;
%page;
/**** Routine to wait for tape I/O to complete.  It will loop forever if
      one isn't returned. */

WAIT_FOR_STATUS:
     procedure (buf_num);
dcl	buf_num		fixed bin parm;

	io_post_buffer_ptr = addr (ioi_post_area.buffer (buf_num));
	do while (io_post_buffer.state ^= IO_COMPLETE);
	     call CHECK_ABORT;			/* operator interrupt? */
	end;
	return;
     end WAIT_FOR_STATUS;
%page;
/**** Routine that take an I/O buffer that has been queued for a disk
      write and asks that it now take place.  */

WRITE_DISK:
     procedure;

	iob.state = DISK_BUSY;
	iob.state_time = clock ();
	call bootload_disk_io$queue_write ((pv.pvtx), (iob.head.rec_on_pv), 1, ptr (tcb.wksp, iob.datax),
	     iob.disk_post_buf, code);
	return;
     end WRITE_DISK;
%page;
/**** Routine to write the current volume preamble from the temp segment
      to tape. This is called before each volume is saved. */

WRITE_PREAMBLE:
     procedure;

	call ISSUE (WRITE_EOF);
	call syserr (ANNOUNCE, "^a(^a): Volume ^a, record ^d, on tape# ^a (^a)", my_name, si.tape_set, vol_info.pvname,
	     vol_info.restart.rec_on_pv, ltrim (tape_label.tape_number, "0"), tcb.name);
	call GET_TAPE_BUFFER;
	iob.write = YES;
	si.datap -> page = vol_preamblep -> page;	/* copy preamble */
	iob.head.type, iob.head.rec_on_pv = 0;
	iob.head.rec_in_type = 0;
	call SETUP_REC_HEADER (PV_PREAMBLE);
	call WRITE_RECORD;				/* write data to tape */
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;
	tcb.records_written = tcb.records_written + 1;
	call FREE_BUFFER;
	si.written_preamble = YES;
	si.write_eof = YES;				/* force writting of EOF on next I/O */
	return;
     end WRITE_PREAMBLE;
%page;
/**** Routine that take an I/O buffer that has been queued for a tape
      write and asks that it now take place.  */

WRITE_RECORD:
     procedure;

	iob_hold_ptr = iobp;
	if iob.head.type = PV_PART
	then if iob.head.rec_in_type = 0
	     then call syserr (ANNOUNCE, "^a(^a):^3xPartition ^a, record ^d, on tape# ^a (^a)", my_name, si.tape_set,
		     iob.head.part_name, iob.head.rec_on_pv, ltrim (tape_label.tape_number, "0"), tcb.name);
setup_idcw:
	idcwp = addr (iob.idcw_word);
	unspec (idcw) = ""b;
	idcw.command = WRITE_BINARY;
	idcw.device = bit (bin (tcb.device, 6), 6);	/* fill in device# */
	idcw.code = IDCW;

	if tcb.statusx ^= si.ioi_statusx then do;
	     si.ioi_statusx = tcb.statusx;
	     tcb.status_idx = 0;
	     call ioi_set$status (tcb.ioi_index, si.ioi_statusx, (tcb.status_count), code);
	     if code ^= 0 then do;
		call syserr$error_code (BEEP, code, "^a: Setting status index for ^a.^66t***^/^-", my_name, tcb.name);
		call ABORT;
	     end;
	end;
	iob.state = TAPE_BUSY;
	iob.state_time = clock ();
	if iob.head.type = TAPE_LABEL | iob.head.type = TAPE_EOR | iob.head.type = PV_PREAMBLE | iob.head.end_of_part
	     | iob.head.end_of_pv | tcb.eot
	then goto do_tape_connect;			/* don't attempt further threading if exception exists */
	prev_iobp = iobp;
	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = TAPE_QUEUED
	     then if OLDEST_BUFFER (iobp, TAPE_QUEUED) then do;
		     if iob.head.rec_in_type = 0 then goto do_tape_connect;
						/* if switched areas then save for after write EOF */
						/* else thread this iob to previous iob */
		     prev_iobp -> iob.next_statex = bin (rel (iobp), 18);
		     idcwp = addr (prev_iobp -> iob.idcw_word);
		     idcw.control = CONTINUE_NO_MARKER;
		     tdcwp = addr (prev_iobp -> iob.tdcw_word);
		     unspec (tdcw) = ""b;
		     tdcw.address = rel (addr (iob.idcw_word));
		     tdcw.type = TDCW;
		     tdcw.rel = ON;
		     goto setup_idcw;		/* setup the rest of the iob */
		end;
		else ;
	end;
do_tape_connect:
	iobp = iob_hold_ptr;
	idcwp = addr (iob.idcw_word);
	if ^tcb.density_set then do;			/* chk if density chaining needed */
	     stat_ws.idcw = DEFAULT_IDCW;
	     idcwp = addr (stat_ws.idcw);
	     idcw.command = tcb.density_command;
	     idcw.device = bit (bin (tcb.device, 6), 6);	/* fill in device# */
	     idcw.control = CONTINUE_NO_MARKER;
	     tdcwp = addr (stat_ws.tdcw);
	     unspec (tdcw) = ""b;
	     tdcw.address = rel (addr (iob.idcw_word));
	     tdcw.type = TDCW;
	     tdcw.rel = ON;
	end;
	call TAPE_CONNECT (bin (rel (idcwp), 18));
	return;
     end WRITE_RECORD;
%page;
/**** Routine that sets up the end of reel record and has it written to
      tape. */

WRITE_TAPE_EOR:
     procedure;

	call ISSUE (WRITE_EOF);
	call GET_TAPE_BUFFER;
	iob.write = YES;
	si.datap -> page (*) = OFF;			/* zero data */
	iob.head.type, iob.head.rec_on_pv = 0;
	iob.head.rec_in_type = 0;
	call SETUP_REC_HEADER (TAPE_EOR);
	call WRITE_RECORD;				/* write data to tape */
	call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	call CHECK_STATUS;
	tcb.records_written = tcb.records_written + 1;
	call FREE_BUFFER;
	call ISSUE (WRITE_EOF);
	call ISSUE (WRITE_EOF);
	call ISSUE (WRITE_EOF);			/* one extra just in case! */
	return;
     end WRITE_TAPE_EOR;
%page;
/**** Routine that is responsible for writting the tape label info from
      the temp segment to tape. */

WRITE_TAPE_LABEL:
     procedure;
dcl	p9999		pic "9999" based;
dcl	tlx		fixed bin;

	if si.need_info_tape then do;			/* writing "Info" tape */
	     tape_label.tape_number = "Info";
	     tape_label.tapes_in_set = si.tape_seq_number;
	end;
	else do;
	     si.tape_seq_number = si.tape_seq_number + 1; /* increment tape# */
	     tape_label.tape_number = convert (p9999, si.tape_seq_number);
	     vol_info.restart.rec_on_pv =
		find_bit_$first_off (substr (bit_map, si.recordx + 2, (si.last_rec + 1) - (si.recordx + 1)))
		+ si.recordx;			/* will be next PV record written */
	     vol_info.restart.rec_in_type = si.current_rec_in_area + 1;
	end;
	tape_label.vol_array_idx = si.pvx;
check_tape_state:
	if ^TAPE_DEVICE_READY ()
	then if ^MOUNTED_TAPE () then do;
		call NEXT_TAPE_DEVICE;
		goto check_tape_state;
	     end;
	     else ;
	if tcb.write_protected then do;
	     call UNLOAD_TAPE;
	     call syserr (BEEP, "^a(^a): Remount tape# ^a WITH write ring on ^a.", my_name, si.tape_set,
		ltrim (tape_label.tape_number, "0"), tcb.name);
	     tcb.mount_requested = YES;		/* already informed opr. */
	     goto check_tape_state;
	end;
	call REWIND_TAPE;
	tape_label.save_time = clock ();		/* mark creation time */
	call GET_TAPE_BUFFER;
	iob.write = YES;
	iob.head.type, iob.head.rec_on_pv = 0;
	do tlx = 0 to divide (size (tape_label) + PAGE_SIZE - 1, PAGE_SIZE, 17) - 1;
						/* write label records */
	     si.datap -> page = addrel (tape_labelp, tlx * PAGE_SIZE) -> page;
						/* copy data */
	     iob.head.rec_in_type = tlx;
	     call SETUP_REC_HEADER (TAPE_LABEL);
	     call WRITE_RECORD;			/* write data to tape */
	     call WAIT_FOR_STATUS (si.ioi_term_post_buf);
	     call CHECK_STATUS;
	     if bad_density_status then do;
		call syserr (ANNOUNCE, "^a(^a): Unable to set density on ^a.^66t***", my_name, si.tape_set, tcb.name);
		call FREE_BUFFER;
		call NEXT_TAPE_DEVICE;
		goto check_tape_state;
	     end;
	     else tcb.density_set = YES;
	     tcb.records_written = tcb.records_written + 1;
	end;
	call FREE_BUFFER;
	si.written_tape_label = YES;
	tcb.tape_vol_number = tape_label.tape_number;
	return;
     end WRITE_TAPE_LABEL;
%page;
/**** This routine is used to zero all the partitions that were not restored
      from the save tapes, when "part -all" is used. The partitions "alt",
      "bce" and "hc" are excluded from the zeroing process. */

ZERO_PARTS_NOT_RESTORED:
     procedure;

	call GET_DISK_BUFFER;
	iob.head.rec_on_pv = LABEL_ADDR;
	call READ_DISK;				/* read PV label */
	do while (^DISK_DATA_READY ());
	end;
	vol_preamblep -> page = si.datap -> page;
	call FREE_BUFFER;
	do i = lbound (vol_preamble.parts, 1) to vol_preamble.nparts;
	     if vol_preamble.parts (i).part = "alt"
		| (vol_preamble.pv_name = "rpv" & vol_preamble.parts (i).part = "bce")
		| vol_preamble.parts (i).part = "hc"
	     then goto skip_zeroing;
	     do partx = pv.part_idx repeat part_array (partx).next_idx while (partx ^= 0);
		if part_array (partx).name = vol_preamble.parts (i).part & ^part_array (partx).removed
		then goto skip_zeroing;
	     end;
	     call syserr (ANNOUNCE, "^a(^a):^3xZeroing partition ^a on ^a, record ^d.", my_name, si.tape_set,
		vol_preamble.parts (i).part, pv.name, vol_preamble.parts (i).frec);
	     call GET_DISK_BUFFER;
	     unspec (si.datap -> page) = ""b;		/* zero data */
	     do j = 0 to vol_preamble.parts (i).nrec - 1;
		iob.head.rec_on_pv = vol_preamble.parts (i).frec + j;
		iob.head.rec_in_type = j;
		iob.head.part_name = vol_preamble.parts (i).part;
		call WRITE_DISK;
		do while (^DISK_DATA_READY ());
		end;
	     end;
	     call FREE_BUFFER;
skip_zeroing:
	end;
	return;
     end ZERO_PARTS_NOT_RESTORED;
%page;
/**** Automatic */

dcl	argx		fixed bin;
dcl	arg_count		fixed bin;
dcl	arg_lth		fixed bin (21);
dcl	arg_ptr		ptr;
dcl	bad_density_status	bit (1);
dcl	1 save_restore_info aligned like sri;
dcl	1 cf_array	(32) aligned like cf_info;
dcl	code		fixed bin (35);
dcl	date_time_string	char (24);
dcl	density_idx	fixed bin;
dcl	display_info_tape	bit (1);
dcl	done		bit (1);
dcl	end_of_file_status	bit (1);
dcl	fb71		fixed bin (71);
dcl	force_tape_run	bit (1);
dcl	i		fixed bin;
dcl	iob_hold_ptr	ptr;
dcl	j		fixed bin;
dcl	my_name		char (8);
dcl	opr_input		char (128);		/* area to hold operator input */
dcl	partx		fixed bin;
dcl	1 part_area	(4, 64) aligned like part;
dcl	prev_iobp		ptr;
dcl	1 pv_area		(4, 63) aligned like pv;
dcl	restoring		bit (1);
dcl	setx		fixed bin (17);		/* current set_info index */
dcl	1 set_info	(4) aligned like si;	/* per set info array */
dcl	supress_error_recovery
			bit (1);
dcl	1 tcb_area	(4, 0:16) aligned like tcb;
dcl	tape_drive_string	char (80) varying;
dcl	tape_retries	fixed bin;
dcl	yes_no		bit (1);
dcl	volx		fixed bin;
dcl	vol_map_bits_to_move
			fixed bin;

/**** Based variables */

dcl	arg		char (arg_lth) based (arg_ptr);

dcl	bit_map		bit (110592) unal based (si.bit_map_ptr);
						/* 3 pages, recs 0 - 327777 */

dcl	1 cf_info		aligned based,
	  2 name		char (32),		/* name of file */
	  2 set		fixed bin,		/* SET file is in */
	  2 length	fixed bin (21),		/* char length of file */
	  2 ptr		ptr;			/* pointer to file */

dcl	debug_based_block	(4) bit (36) based;
dcl	page		(0:1023) bit (36) aligned based;

/**** Constants & Builtins */

dcl	ALL_PARTS		char (4) int static options (constant) init ("-all");
dcl	ANY_DENSITY	bit (5) int static options (constant) init ("11111"b);
dcl	AUTO_READ_RETRY	bit (6) int static options (constant) init ("30"b3);
dcl	BAD		bit (1) aligned int static options (constant) init ("0"b);
dcl	C1_PATTERN	bit (36) int static options (constant) init ("542553413076"b3);
dcl	CONTINUE_NO_MARKER	bit (2) int static options (constant) init ("10"b);
dcl	DEFAULT_IDCW	bit (36) int static options (constant) init ("000000700201"b3);
dcl	DEV_ATTENTION	bit (4) int static options (constant) init ("0010"b);
dcl	DEV_READY		bit (4) int static options (constant) init ("0000"b);
dcl	DEV_STANDBY	bit (6) int static options (constant) init ("04"b3);
dcl	DEV_SURVEY_DATA_SIZE
			fixed bin int static options (constant) init (8);
dcl	DEV_WRITE_PROTECTED bit (6) int static options (constant) init ("01"b3);
dcl	DEV_WRITE_PROTECT_MASK
			bit (6) int static options (constant) init ("01"b3);
dcl	FAULT_INTERRUPT	fixed bin int static options (constant) init (1);
dcl	FIRST_READ_RETRY_CMD
			fixed bin int static options (constant) init (25);
dcl	FIRST_TAPE_DEV_IDX	fixed bin int static options (constant) init (1);
dcl	GOOD		bit (1) aligned int static options (constant) init ("1"b);
dcl	IDCW		bit (3) int static options (constant) init ("7"b3);
dcl	LAST_READ_RETRY_CMD bit (6) int static options (constant) init ("37"b3);
dcl	MAX_BUFFERS	fixed bin int static options (constant) init (6);
dcl	MAX_READ_RETRY	fixed bin int static options (constant) init (7);
dcl	MTH_TO_READY	bit (8) int static options (constant) init ("10"b4);
dcl	NO		bit (1) aligned int static options (constant) init ("0"b);
dcl	NO_CONTINUE_NO_MARKER
			bit (2) int static options (constant) init ("00"b);
dcl	NON_DATA_XFER	bit (6) int static options (constant) init ("02"b3);
dcl	OFF		bit (1) aligned int static options (constant) init ("0"b);
dcl	ON		bit (1) aligned int static options (constant) init ("1"b);
dcl	ONE_RECORD	bit (6) int static options (constant) init ("01"b3);
dcl	ONE_WEEK		fixed bin (71) int static options (constant) init (604800000000);
dcl	QUEUE_THRESHOLD	fixed bin int static options (constant) init (3);
dcl	SPECIAL_INTERRUPT	fixed bin int static options (constant) init (7);
dcl	STATUS_MASK	bit (36) int static options (constant) init ("370000770000"b3);
dcl	SURVEY_IDCW	bit (36) int static options (constant) init ("570000700000"b3);
dcl	TDCW		bit (2) unaligned int static options (constant) init ("10"b);
dcl	TERMINATE_INTERRUPT fixed bin int static options (constant) init (3);
dcl	TWO_RECORDS	bit (6) int static options (constant) init ("02"b3);
dcl	VTOCES_PER_WORD	fixed bin (17) int static options (constant) init (32);
dcl	YES		bit (1) aligned int static options (constant) init ("1"b);
dcl	density_commands	(5) bit (6) int static options (constant) init ("64"b3, "61"b3, "60"b3, "65"b3, "41"b3);
dcl	current_density	(5) bit (5) int static options (constant) init ("10000"b,
						/* 200 bpi */
			"01000"b,			/* 556 bpi */
			"00100"b,			/* 800 bpi */
			"00010"b,			/* 1600 bpi */
			"00001"b);		/* 6250 bpi */

/**** IDCW.command Constants */

dcl	BACKSPACE		bit (6) int static options (constant) init ("46"b3);
dcl	ERASE		bit (6) int static options (constant) init ("54"b3);
dcl	FORWARD_SPACE_FILE	bit (6) int static options (constant) init ("45"b3);
dcl	READ_BINARY	bit (6) int static options (constant) init ("05"b3);
dcl	REQUEST_STATUS	bit (6) int static options (constant) init ("00"b3);
dcl	REWIND		bit (6) int static options (constant) init ("70"b3);
dcl	WRITE_BINARY	bit (6) int static options (constant) init ("15"b3);
dcl	WRITE_EOF		bit (6) int static options (constant) init ("55"b3);
dcl	UNLOAD		bit (6) int static options (constant) init ("72"b3);

/**** Buffer State Constants */

dcl	FREE		fixed bin int static options (constant) init (0);
dcl	DISK_SUSPEND	fixed bin int static options (constant) init (1);
dcl	DISK_QUEUED	fixed bin int static options (constant) init (2);
dcl	DISK_BUSY		fixed bin int static options (constant) init (3);
dcl	DISK_READY	fixed bin int static options (constant) init (4);
dcl	TAPE_SUSPEND	fixed bin int static options (constant) init (5);
dcl	TAPE_QUEUED	fixed bin int static options (constant) init (6);
dcl	TAPE_BUSY		fixed bin int static options (constant) init (7);
dcl	TAPE_READY	fixed bin int static options (constant) init (8);

dcl	(addr, addrel, after, bin, bit, clock, convert, divide, hbound, lbound, length, ltrim, min, mod, null, ptr, rel,
	size, substr, unspec)
			builtin;

dcl	cleanup		condition;
dcl	sub_request_abort_	condition;

/**** External variables & entries */

dcl	error_table_$not_done
			fixed bin (35) ext static;
dcl	error_table_$seg_not_found
			fixed bin (35) ext static;
dcl	wired_hardcore_data$abort_request
			bit (1) aligned external;

dcl	bce_query		entry options (variable);
dcl	bce_query$yes_no	entry options (variable);
dcl	bce_save_util_$display_info_tape
			entry (ptr);
dcl	bce_save_util_$init_buffers
			entry (ptr);
dcl	bce_save_util_$ioi_attach
			entry (ptr);
dcl	bce_save_util_$is_fips_device
			entry (ptr) returns (bit (1));
dcl	bce_save_util_$last_vtoc_used
			entry (ptr) returns (fixed bin (18));
dcl	bce_save_util_$locate_tape_number
			entry (ptr);
dcl	bce_save_util_$premount_check
			entry (ptr);
dcl	bce_save_util_$read_pv_label
			entry (ptr);
dcl	bce_save_util_$scan_control_file
			entry (ptr);
dcl	bce_save_util_$scan_survey_data
			entry (ptr, ptr);
dcl	bce_save_util_$setup_all_parts
			entry (ptr);
dcl	bce_save_util_$skip_tape_device
			entry (ptr) returns (bit (1));
dcl	bce_save_util_$sort_pv_list
			entry (ptr);
dcl	bce_save_util_$thread_partition_list
			entry (ptr);
dcl	bootload_disk_io$queue_read
			entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin, fixed bin (35));
dcl	bootload_disk_io$queue_write
			entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin, fixed bin (35));
dcl	bootload_disk_io$test_done
			entry (fixed bin, fixed bin (35));
dcl	com_err_		entry () options (variable);
dcl	cu_$arg_count_rel	entry (fixed bin, ptr, fixed bin (35));
dcl	cu_$arg_ptr_rel	entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	get_temp_segment_	entry (char (*), ptr, fixed bin (35));
dcl	ioa_		entry () options (variable);
dcl	ioi_assignment$unassign
			entry (fixed bin, fixed bin (35));
dcl	ioi_connect	entry (fixed bin, fixed bin (18), fixed bin (35));
dcl	ioi_get_status$detailed_status
			entry (fixed bin, bit (1) aligned, bit (*), fixed bin (35));
dcl	ioi_set$status	entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
dcl	release_temp_segment_
			entry (char (*), ptr, fixed bin (35));
dcl	syserr		entry () options (variable);
dcl	syserr$error_code	entry () options (variable);
dcl	find_bit_$first_off entry (bit (*)) returns (fixed bin (24));
dcl	find_bit_$last_off	entry (bit (*)) returns (fixed bin (24));
%page;
%include bce_ioi_post_area;
%page;
%include bce_subsystem_info_;
%page;
%include bsr_structures;
%page;
%include bsr_tape_data;
%page;
%include bootload_post_area;
%page;
%include config_data_dcls;
%page;
%include config_prph_tap_card;
%page;
%include disk_pack;
%page;
%include fs_dev_types;
%page;
%include io_special_status;
%page;
%include io_status_word;
%page;
%include ioi_stat;
%page;
%include iom_dcw;
%page;
%include iom_pcw;
%page;
%include pvt;
%page;
%include pvte;
%page;
%include syserr_constants;
%page;
%include tape_error_interp;
%page;
%include vol_map;
%page;
%include vtoc_map;
%page;
/*^ BEGIN MESSAGE DOCUMENTATION

   Message:
   bce_save: Error issuing tape connect for TAPE_DEV (TAPE_SET). ERR_MESSAGE

   S:	$crash

   T:	$init

   M:	IOI has returned a non-zero error, which has been expanded in
   ERR_MESSAGE.  $err

   A:	$inform

   Message:
   bce_save: IO complete, but NO status returned for TAPE_SET.

   S:	$crash

   T:	$init

   M:	An I/O has been posted, but there was no indication of status
   being returned.  $err

   A:	$inform

   Message:
   bce_save: Internal bit map for PV_NAME (TAPE_SET) contains no in use pages.

   S:	$crash

   T:	$init

   M:	The copied/packed internal version of the PV's volume bit map
   contains no used pages (OFF bits).  $err

   A:	$inform

   Message:
   bce_save: Out of disk buffers for TAPE_SET.

   S:	$crash

   T:	$init

   M:	$err

   A:	$inform

   Message:
   bce_save: Out of tape buffers for TAPE_SET.

   S:	$crash

   T:	$init

   M:	$err

   A:	$inform

   Message:
   restore(TAPE_SET): "Info" tape on TAPE_DEV, created DATE_TIME

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): (Unrecoverable) MAJOR_STATUS, SUB_STATUS on TAPE_DEV.

   S:	$info

   T:	$init

   M:	An unrecoverable error has occured while attempting to do I/O to
   the tape device.

   A:	$recover

   Message:
   restore(TAPE_SET): Abnormal tape termination of tape# TAPE_NUMBER on TAPE_DEV.

   S:	$info

   T:	$init

   M:	While reading the save tape an invalid record header was found.
   BCE save tapes are normally terminated with a End-of-Reel (EOR) record
   followed by three End-of-File (EOF) marks.  This one most likely was
   not properly terminated.

   A:	$ignore  Unless it is felt that the tape is properly terminated,
   in which case the restore can be restarted and this tape re-read.

   Message:
   restore(TAPE_SET): Clearing unused VTOC region (records BEGIN_REC - END_REC) on PV_NAME.

   S:	$info

   T:	$init

   M:	Just an informative message.  The unused records in the VTOC region
   are zero cleared to avoid having erroneous VTOCEs left laying around.

   A:	$ignore

   Message:
   restore(TAPE_SET): Device TAPE_DEV is being removed from the tape device list.

   S:	$info

   T:	$init

   M:	The TAPE_DEV has returned a status indicating that it is unable
   to be used.

   A:	$ignore

   Message:
   restore(TAPE_SET): End of Information without detecting TAPE_EOR record.

   S:	$info

   T:	$init

   M:	Multiple End-of-File (EOF) marks have been detected, without
   previously reading an End-of-Reel (EOR) record.

   A:	$ignore Unless it is felt that the tape is properly terminated,
   in which case the restore can be restarted and this tape re-read.

   Message:
   restore(TAPE_SET): Error, tape on TAPE_DEV is part of the "OTHER_TAPE_SET" set.

   S:	$info

   T:	$init

   M:	The tape just read is not part of this tape set.

   A:	Mount a tape on the device that is part of this tape set.

   Message:
   restore: Getting tape label temp segment. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error occured while attempting to get a temporary segment to
   hold the tape label information.

   A:	$inform

   Message:
   restore(TAPE_SET): Incorrect tape number. Expected tape# TAPE_NUMBER.

   S:	$info

   T:	$init

   M:	An internal tape number tracking mechanism is used and the tape
   that was just read does not match what the program expects to be on the
   device.

   A:	Mount the correct tape on the device.

   Message:
   restore(TAPE_SET): MAJOR_STATUS, SUB_STATUS on TAPE_DEV.

   S:	$info

   T:	$init

   M:	An error has occured while attempting to do I/O to the tape
   device.

   A:	$recover

   Message:
   restore(TAPE_SET): No Physical Volumes left to restore.

   S:	$info

   T:	$init

   M:	For various reasons all of the physical volumes have been
   removed from the list of volumes.

   A:	$ignore

   Message:
   restore(TAPE_SET): No room to describe PV PV_NAME for part PARTITION_NAME.

   S:	$info

   T:	$init

   M:	The maximum number of physical volumes that can be handled by
   the program has been exceeded.

   A:	The number of physical volumes defined in the control file(s)
   must be reduced.

   Message:
   restore(TAPE_SET): No usable tape devices left in list.

   S:	$info

   T:	$init

   M:	For various reasons all of the tape devices have been removed
   from the list of available devices for this tape set.

   A:	$recover

   Message:
   restore(TAPE_SET): No usable tape drives left.

   S:	$info

   T:	$init

   M:	For various reasons all of the tape devices have been removed
   from the list of available devices for this tape set.

   A:	$recover

   Message:
   restore: PV_NAME ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The call to bootload_disk_io$test_done has returned a non-zero
   error code.

   A:	$inform $recover

   Message:
   restore(TAPE_SET): Partition PARTITION_NAME on PV_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Partition PARTITION_NAME was not defined when PV_NAME was saved.

   S:	$info

   T:	$init

   M:	A restore of a partition has been requested in the control file,
   but the partition was not requested to be saved when the tape was made.

   A:	Remove the partition reference from the control file.

   Message:
   restore(TAPE_SET): Partition PARTITION_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Please mount tape# TAPE_NUMBER on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount tape on the device.

   Message:
   restore(TAPE_SET): Please mount the "Info" tape on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount the tape on the device.

   Message:
   restore(TAPE_SET): Please mount the "restart" tape on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount the tape on the device.

   Message:
   restore(TAPE_SET): Readjusting tape sequence # to REC_NUM.

   S:	$info

   T:	$init

   M:	The missing record previously reported by the "Record sequence
   error ..." message can not be found.  The internal tape sequence counter
   is corrected and processing continues as normal.

   A:	$ignore

   Message:
   restore(TAPE_SET): Record sequence error on tape# TAPE_NUMBER (TAPE_DEV),
   should be record # REC_NUM, was record # REC_NUM.

   S:	$info

   T:	$init

   M:	Informative message that the sequence number on the tape is out
   of sync with what the program expects.  If the WAS is only one record
   more than the S/B then the program will attempt to relocate the missing
   record by backspacing two records and rereading the records.

   A:	$ignore

   Message:
   restore: Restarting restore of set "TAPE_SET" on TAPE_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Restore of volume PV_NAME on DISK_DEV complete.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Relocated tape sequence # REC_NUM

   S:	$info

   T:	$init

   M:	The missing record previously reported by the "Record sequence
   error ..." message has been found.  Processing continues as normal.

   A:	$ignore

   Message:
   restore: Setting status index for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error, which has been expanded in
   ERR_MESSAGE.

   A:	$inform

   Message:
   restore(TAPE_SET): Skipping volume PV_NAME on DISK_DEV, restore complete.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(check_status): Special Interrupt: STATUS_WORD

   S:	$info

   T:	$init

   M:	An unexpected special interrupt has been detected.

   A:	$ignore

   Message:
   restore(TAPE_SET): Starting from volume PV_NAME on DISK_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore: Stopping restore of set "TAPE_SET".

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Tape on TAPE_DEV does not contain a supported tape label version.

   S:	$info

   T:	$init

   M:	The tape contains a tape version identifier that is nolonger
   supported.

   A:	Use the "restore -display_info_tape tapX_NN" option to display
   the tape.

   Message:
   restore(TAPE_SET): Tape on TAPE_DEV does not contain a valid label.

   S:	$info

   T:	$init

   M:	The tape just read is not a valid save/restore tape.

   A:	$recover

   Message:
   restore(TAPE_SET): Tape on TAPE_DEV is not part of this set.

   S:	$info

   T:	$init

   M:	The tape just read contains a different tape set name than what
   is currently being handled, via the control file.

   A:	$recover

   Message:
   restore(TAPE_SET): Tape# TAPE_NUMBER on TAPE_DEV, created DATE_TIME

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): The following tape device(s) will be used:

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(check_status): Time-Out on TAPE_DEV

   S:	$info

   T:	$init

   M:	An I/O that was issued to the tape device has timed-out.

   A:	$recover

   Message:
   restore(TAPE_SET): Time-out waiting for special interrupt.

   S:	$info

   T:	$init

   M:	The program was waiting for a special to come from the device,
   but none was recieved in the alloted time.

   A:	$recover

   Message:
   restore(TAPE_SET): Unable to set density on TAPE_DEV.

   S:	$info

   T:	$init

   M:	The program was unable to set the required density of the tape
   device.

   A:	$recover

   Message:
   restore: Unassigning TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error, which has been expanded in
   ERR_MESSAGE.

   A:	$inform

   Message:
   restore(TAPE_SET): Unloading "Info" tape from TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Unloading TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Unloading tape# TAPE_NUMBER from TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Volume PV_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Waiting for special on TAPE_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): Zeroing partition PARTITION_NAME on PV_NAME, record REC_NUM.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore: bce_ioi_post_seg. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   restore: bootload_disk_post_seg. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   restore: pvt. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   restore(TAPE_SET): restore complete...

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore: tape_error_data. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   save(TAPE_SET): (Unrecoverable) MAJOR_STATUS, SUB_STATUS on TAPE_DEV.

   S:	$info

   T:	$init

   M:	An unrecoverable error has occured while attempting to do I/O to
   the tape device.

   A:	$recover

   Message:
   save(TAPE_SET): Device TAPE_DEV is being removed from the tape device list.

   S:	$info

   T:	$init

   M:	The TAPE_DEV has returned a status indicating that it is unable
   to be used.

   A:	$ignore

   Message:
   save(TAPE_SET): Error, tape on TAPE_DEV is part of the "OTHER_TAPE_SET" set.

   S:	$info

   T:	$init

   M:	The tape just read is not part of this tape set.

   A:	Mount a tape on the device that is part of this tape set.

   Message:
   save: Getting tape label temp segment. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error occured while attempting to get a temporary segment to
   hold the tape label information.

   A:	$inform

   Message:
   save(TAPE_SET): Incorrect tape sequence number detected.
.brf
   was REC_NUM, s/b REC_NUM. Forcing restart of this tape set.

   S:	$beep

   T:	$init

   M:	A sequence error was detected in the tape record number.
   $err

   A:	Follow normal save restart procedures.
   $inform

   Message:
   save(TAPE_SET): MAJOR_STATUS, SUB_STATUS on TAPE_DEV.

   S:	$info

   T:	$init

   M:	An error has occured while attempting to do I/O to the tape
   device.

   A:	$recover

   Message:
   save(TAPE_SET): No Physical Volumes left to save.

   S:	$info

   T:	$init

   M:	For various reasons all of the physical volumes have been
   removed from the list of volumes.

   A:	$ignore

   Message:
   save(TAPE_SET): No room to describe PV PV_NAME for part PARTITION_NAME.

   S:	$info

   T:	$init

   M:	The maximum number of physical volumes that can be handled by
   the program has been exceeded.

   A:	The number of physical volumes defined in the control file(s)
   must be reduced.

   Message:
   save(TAPE_SET): No usable tape devices left in list.

   S:	$info

   T:	$init

   M:	For various reasons all of the tape devices have been removed
   from the list of available devices for this tape set.

   A:	$recover

   Message:
   save(TAPE_SET): No usable tape drives left.

   S:	$info

   T:	$init

   M:	For various reasons all of the tape devices have been removed
   from the list of available devices for this tape set.

   A:	$recover

   Message:
   save: PV_NAME ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The call to bootload_disk_io$test_done has returned a non-zero
   error code.

   A:	$inform $recover

   Message:
   save(TAPE_SET): Partition PARTITION_NAME on PV_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Partition PARTITION_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Please mount tape# TAPE_NUMBER on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount tape on the device.

   Message:
   save(TAPE_SET): Please mount the "Info" tape on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount the tape on the device.

   Message:
   save(TAPE_SET): Please mount the "restart" tape on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	Just an informative message.

   A:	Mount the tape on the device.

   Message:
   save(TAPE_SET): Remount tape# TAPE_NUMBER WITH write ring on TAPE_DEV.

   S:	$beep

   T:	$init

   M:	The tape is currently mounted without a write ring present.

   A:	Remount tape with write permit ring in place.

   Message:
   save: Restarting save of set "TAPE_SET" on TAPE_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save: Setting status index for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error, which has been expanded in
   ERR_MESSAGE.

   A:	$inform

   Message:
   save(TAPE_SET): Skipping volume PV_NAME on DISK_DEV, save complete.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(check_status): Special Interrupt: STATUS_WORD

   S:	$info

   T:	$init

   M:	An unexpected special interrupt has been detected.

   A:	$ignore

   Message:
   save(TAPE_SET): Starting from volume PV_NAME on DISK_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save: Stopping save of set "TAPE_SET".

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Tape on TAPE_DEV does not contain a supported tape label version.

   S:	$info

   T:	$init

   M:	The tape contains a tape version identifier that is nolonger
   supported.

   A:	Use the "restore -display_info_tape tapX_NN" option to display
   the tape.

   Message:
   save(TAPE_SET): Tape on TAPE_DEV does not contain a valid label.

   S:	$info

   T:	$init

   M:	The tape just read is not a valid save/restore tape.

   A:	$recover

   Message:
   save(TAPE_SET): Tape on TAPE_DEV is not part of this set.

   S:	$info

   T:	$init

   M:	The tape just read contains a different tape set name than what
   is currently being handled, via the control file.

   A:	$recover

   Message:
   save(TAPE_SET): Tape# TAPE_NUMBER on TAPE_DEV, created DATE_TIME

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): The following tape device(s) will be used:

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): This tape is older than one week. Tape rejected.

   S:	$info

   T:	$init

   M:	A restart of a save is being attempted, but the tape used as the
   restart tape is older than one week.

   A:	Restart with a later tape or start the save from the beginning.

   Message:
   save(TAPE_SET): This tape starts with volume PV_NAME,
   which was not defined. Tape rejected.

   S:	$info

   T:	$init

   M:	A save restart is being attempted with a tape that begins with a
   PV that has not been defined in the save control file(s).

   A:	$recover

   Message:
   save(check_status): Time-Out on TAPE_DEV

   S:	$info

   T:	$init

   M:	An I/O that was issued to the tape device has timed-out.

   A:	$recover

   Message:
   save(TAPE_SET): Time-out waiting for special interrupt.

   S:	$info

   T:	$init

   M:	The program was waiting for a special to come from the device,
   but none was recieved in the alloted time.

   A:	$recover

   Message:
   save(TAPE_SET): Unable to set density on TAPE_DEV.

   S:	$info

   T:	$init

   M:	The program was unable to set the required density of the tape
   device.

   A:	$recover

   Message:
   save: Unassigning TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error, which has been expanded in
   ERR_MESSAGE.

   A:	$inform

   Message:
   save(TAPE_SET): Unloading "Info" tape from TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Unloading TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Unloading tape# TAPE_NUMBER from TAPE_DEV, REC_CNT records (ERR_CNT errors)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Volume PV_NAME, record REC_NUM, on tape# TAPE_NUMBER (TAPE_DEV)

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Waiting for special on TAPE_DEV.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save: bce_ioi_post_seg. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   save: bootload_disk_post_seg. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   save: pvt. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   Message:
   save(TAPE_SET): save complete...

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save: tape_error_data. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The program was unable to get a pointer to the above segment.
   $err

   A:	$inform

   END MESSAGE DOCUMENTATION */

     end bce_save;




		    bce_save_util_.pl1              11/11/89  1135.4r w 11/11/89  0826.7      693729



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1986 *
        *                                                         *
        *********************************************************** */

/* format: style4,declareind10,dclind10,idind20,indattr,delnl,insnl,ifthenstmt */

bce_save_util_:
     procedure (a_sri_ptr);

/****^  HISTORY COMMENTS:
  1) change(86-09-18,Farley), approve(86-07-18,MCR7439),
     audit(86-09-24,Fawcett), install(86-10-20,MR12.0-1189):
     Collection of Save/Restore routines that are not part of the main
     stream save/restore loop and do not reference main stream procedures.
     Therefore they can take the time to push a stack frame.
  2) change(87-07-07,Farley), approve(87-07-17,MCR7733),
     audit(87-07-21,Fawcett), install(87-07-31,MR12.1-1051):
     Changed most of the calls to ioa_ and com_err_ to calls to syserr and
     syserr$error_code so that a time stamp will be included in the output..
  3) change(87-11-04,Farley), approve(88-02-26,MCR7811),
     audit(88-03-03,Fawcett), install(88-03-15,MR12.2-1035):
     Changed premount_check entry to only display the pre-mount message if the
     usable tape device count is greater than 1. This is needed because
     bce_save is now calling this entry without checking this count.
  4) change(87-11-16,Farley), approve(88-02-26,MCR7811),
     audit(88-03-03,Fawcett), install(88-03-15,MR12.2-1035):
     Removed the setting of part.zrec, since this value was moved to pv.zrec
     and does not need to be set to a -1.
                                                   END HISTORY COMMENTS */

dcl	a_sri_ptr		ptr parameter;		/* pointer to save/restore info */

	return;					/* main entry not used */
%page;
/**** This entry will display the contents of the "Info" tape. */

bce_save_util_$display_info_tape:
     entry (a_sri_ptr);

	call SETUP;
	call ioa_ ("^/^2x^a, version (^a)^/", info_tape_label.title, info_tape_label.version);
	call ioa_ ("^4xSave time = ^a",
	     date_time_$format ("clock", info_tape_label.save_time, "system_zone", "system_lang"));
	call ioa_ ("^4xTape set ""^a"", which contains ^d tapes^/^4xVolumes in set = ^d", info_tape_label.tape_set,
	     info_tape_label.tapes_in_set, info_tape_label.vol_array_size);
	call ioa_ (
	     "^2/^57tType of^/^50tDevice^xRecords^3xBegin^2xEnd^/^2xPhysical Volume^40tPVID^50tType^3xSaved^5xTape^3xTape^/"
	     );
	do volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size;
	     vol_infop = addr (info_tape_label.vol_array (volx));
	     if vol_info.data_saved = PART_ONLY then do;
		rx = lbound (vol_info.region, 1);
		vol_begin_tape = vol_info.region (1).begins_on_tape;
		vol_end_tape = vol_info.region (vol_info.nregions).ends_on_tape;
	     end;
	     else do;
		rx = lbound (vol_info.region, 1) + 1;	/* skip vtoc/paging region info */
		vol_begin_tape = vol_info.region (1).begins_on_tape;
		vol_end_tape = vol_info.region (1).ends_on_tape;
	     end;
	     call ioa_ ("^2x^32a^x^12.3b^2x^4a^3x^[PV_ONLY  ^;PART_ONLY^;PV/PART  ^]^2x^3d^4x^3d", vol_info.pvname,
		vol_info.pvid, device_names (vol_info.dev_type), vol_info.data_saved + 1, vol_begin_tape,
		vol_end_tape);
	     do rx = rx to vol_info.nregions;
		call ioa_ ("^4xpartition - ^a^68t^3d^4x^3d", vol_info.region (rx).part_name,
		     vol_info.region (rx).begins_on_tape, vol_info.region (rx).ends_on_tape);
	     end;
	end;
	call ioa_ ("^2/");
	return;
%page;
/**** This entry is responsible for setting up the IOI workspace to
      allow for the IO buffers to work properly.  The workspace is setup so
      that the first page is reserved for the IO buffers and status queue
      and the remaining pages will be used for the actual data, minus the
      header (which is in the tape buffer).  This allows the data to be on
      page boundaries and easily sent to/from tape and disk without ever
      having to move it to different memory areas.  NOTE: the first 32
      words of the workspace will be reserved for other IO posibilities. */

bce_save_util_$init_buffers:
     entry (a_sri_ptr);

	call SETUP;
	tcb.buf_listx = bin (rel (tcb.wksp), 18) + 32;
	tcb.nbufs = 0;
	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (tcb.nbufs < MAX_BUFFERS);
	     unspec (iob) = ""b;			/* clear buffer */
	     iob.next_bufx = bin (rel (iobp), 18) + size (iob);
						/* point to next buffer */
	     call FREE_BUFFER;			/* mark it as FREE */
	     iob.disk_post_buf = si.first_disk_post_buf + tcb.nbufs;
						/* set correct disk posting buffer */
	     tcb.nbufs = tcb.nbufs + 1;		/* up the buffer count */
	     if tcb.nbufs = MAX_BUFFERS then do;	/* LAST? */
		iob.next_bufx = 0;			/* mark this as the last */
		tcb.statusx = bin (rel (iobp), 18) + size (iob);
						/* status queue is after last buffer */
	     end;

	     iob.datax = bit (bin (tcb.nbufs * PAGE_SIZE, 18), 18);
						/* page addr = page (buf#) */

	     dcwp = addr (iob.header_dcw);
	     dcw.address = rel (addr (iob.head));
	     dcw.type = IOTP;
	     dcw.tally = bit (bin (size (rec_header), 12));

	     dcwp = addr (iob.data_dcw);
	     dcw.address = iob.datax;
	     dcw.type = IOTD;
	     dcw.tally = bit (bin (PAGE_SIZE, 12));	/* 1 page */
	end;

	tcb.status_count = tcb.nbufs;
	tcb.status_idx = 0;
	si.ioi_statusx = tcb.statusx;
	call ioi_set$status (tcb.ioi_index, si.ioi_statusx, (tcb.status_count), code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Setting status index for ^a.^66t***^/^-", my_name, tcb.name);
	     call ABORT;
	end;

	return;
%page;
/**** Entry to attach the tape device specified in tcb, via IOI. */

bce_save_util_$ioi_attach:
     entry (a_sri_ptr);

	call SETUP;
	unspec (tcb.ioi_ev_chn) = ""b;
	substr (unspec (tcb.ioi_ev_chn), 37, 36) = unspec (substr (tcb.name, 4, 4));
	tcb.wksp = null ();
	si.ioi_statusx = -1;
	call ioi_assignment$assign (tcb.ioi_index, tcb.name, tcb.ioi_ev_chn, OFF, code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Attaching ^a.^66t***^/^-", my_name, tcb.name);
	     call ABORT;
	end;
	call ioi_set$max_workspace (tcb.ioi_index, WORKSPACE_SIZE, code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Setting max workspace for ^a.^66t***^/^-", my_name, tcb.name);
unassign_device:
	     call ioi_assignment$unassign (tcb.ioi_index, code);
	     if code ^= 0 then call syserr$error_code (BEEP, code, "^a: Unassigning ^a.^66t***^/^-", my_name, tcb.name);
	     call ABORT;
	end;
	call ioi_set$workspace (tcb.ioi_index, tcb.wksp, WORKSPACE_SIZE, code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Setting up workspace for ^a.^66t***^/^-", my_name, tcb.name);
	     goto unassign_device;
	end;
	return;
%page;
/**** Entry for finding out if a given tape device is a FIPS type.
      Which is done by finding the first valid device model number from
      the PRPH card, then looking this device up in the config_data_
      segment.  If device numbers start at zero, then it is assumed to be
      part of a FIPS subsystem. */

bce_save_util_$is_fips_device:
     entry (a_sri_ptr) returns (bit (1));
dcl	tap_groupx	fixed bin;

	call SETUP;
	call config_$find_periph (substr (tcb.name, 1, 4), prph_tap_cardp);
	if prph_tap_cardp = null () then do;
	     call syserr (ANNOUNCE, "^a(^a): Tape subsystem ""^a"" is not defined in the config.", my_name, si.tape_set,
		substr (tcb.name, 1, 4));
	     call ABORT;
	end;
	do tap_groupx = lbound (prph_tap_card.group, 1) to hbound (prph_tap_card.group, 1);
	     if prph_tap_card.group (tap_groupx).model ^= 0 then do;
		do i = lbound (config_data_$tape_drive_model_names.names, 1)
		     to config_data_$tape_drive_model_names.count;
		     if config_data_$tape_drive_model_names.names (i).model = prph_tap_card.group (tap_groupx).model
		     then return (config_data_$tape_drive_model_names.names (i).device_0_valid);
		end;
		return (NO);
	     end;
	end;
	return (NO);
%page;
/**** Entry to find the last used vtoce from the vtoc_map, then
      use that to calculate the last vtoc record that is in use.  This
      is done to allow the save to not have to save the vtoc records that
      are not being used, hence speeding up the save. */

bce_save_util_$last_vtoc_used:
     entry (a_sri_ptr) returns (fixed bin (18));
dcl	ALL_FREE_IN_WORD	bit (32) int static options (constant) init ("ffffffff"b4);
dcl	bit_idx		fixed bin;
dcl	last_vtoc_record_used
			fixed bin (18);
dcl	last_vtoce_used	fixed bin;
dcl	vtoce_bit		fixed bin;

	call SETUP;
	call GET_DISK_BUFFER;
	iob.head.rec_on_pv = VTOC_MAP_ADDR;
	call READ_DISK;				/* read vtoc map */
	do while (^DISK_DATA_READY ());
	end;
	si.vol_map_ptr -> page = si.datap -> page;	/* will get overlayed by vol_map */
	call FREE_BUFFER;
	vtoc_mapp = si.vol_map_ptr;
	bit_idx = mod (vtoc_map.n_vtoce, VTOCES_PER_WORD);
	if bit_idx = 0 then bit_idx = VTOCES_PER_WORD;	/* show full word */
	bit_map_wordp = addr (vtoc_map.bit_map (vtoc_map.bit_map_n_words - 1));
	vtoce_bit = find_bit_$last_off (substr (bit_map_word.bits, 1, bit_idx));
	if vtoce_bit > 0 then do;			/* last word has used VTOCE */
	     last_vtoce_used = ((vtoc_map.bit_map_n_words - 1) * VTOCES_PER_WORD) + vtoce_bit - 1;
	     goto set_vtoc_record;
	end;
	do i = vtoc_map.bit_map_n_words - 2 by -1 to lbound (vtoc_map.bit_map, 1);
	     bit_map_wordp = addr (vtoc_map.bit_map (i));
	     if bit_map_word.bits ^= ALL_FREE_IN_WORD then goto found_last;
	end;
	return (VTOC_ORIGIN);			/* No used vtoces */
found_last:
	last_vtoce_used = (i * VTOCES_PER_WORD) + find_bit_$last_off (bit_map_word.bits) - 1;
set_vtoc_record:
	last_vtoc_record_used =
	     VTOC_ORIGIN
	     +
	     divide ((last_vtoce_used + VTOCES_PER_RECORD (pvt_array (pv.pvtx).device_type)),
	     VTOCES_PER_RECORD (pvt_array (pv.pvtx).device_type), 18);
	vtoc_mapp = null ();
	return (last_vtoc_record_used);
%page;
/**** This entry is for finding the number of the tape that should
      be on the current tape device during a restore. */

bce_save_util_$locate_tape_number:
     entry (a_sri_ptr);

	call SETUP;
	do volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size
	     while (info_tape_label.vol_array (volx).pvname ^= pv.name);
	end;
	si.vol_info_ptr, vol_infop = addr (info_tape_label.vol_array (volx));

	if pv.only_part then do;
	     do partx = pv.part_idx repeat part_array (partx).next_idx while (part_array (partx).complete);
	     end;
	     do rx = lbound (vol_info.region, 1) to vol_info.nregions
		while (vol_info.region (rx).part_name ^= part_array (partx).name);
	     end;
	     si.first_tape_number = vol_info.region (rx).begins_on_tape;
	     do partx = partx repeat part_array (partx).next_idx while (partx ^= 0);
	     end;
	     do rx = lbound (vol_info.region, 1) to vol_info.nregions
		while (vol_info.region (rx).part_name ^= part_array (partx).name);
	     end;
	     si.last_tape_number = vol_info.region (rx).ends_on_tape;
	end;
	else do;
	     do rx = lbound (vol_info.region, 1) to vol_info.nregions while (vol_info.region (rx).part_name ^= "");
	     end;
	     si.first_tape_number = vol_info.region (rx).begins_on_tape;
	     si.last_tape_number = vol_info.region (rx).ends_on_tape;
	end;
	if si.tape_seq_number < si.first_tape_number then si.tape_seq_number = si.first_tape_number;
	if si.tape_seq_number = 0 & info_tape_label.tape_number ^= "Info"
	then si.tape_seq_number = bin (info_tape_label.tape_number, 17);
						/* start search with this tape */
	return;
%page;
/**** This entry determines if another tape, after the current one, is going
      to be needed. If needed, then a pre-mount message will be displayed to
      the operator if more than 1 device is usable. */

bce_save_util_$premount_check:
     entry (a_sri_ptr);
dcl	info_volx		fixed bin;
dcl	LARGE_TAPE_NUMBER	fixed bin int static options (constant) init (9999);
dcl	temp_pvx		fixed bin;

	call SETUP;
	si.next_tape_number = si.tape_seq_number + 1;	/* default to next tape# */
	if tcb.tape_vol_number = "" then return;	/* no current tape mounted */
	if si.restart then si.tape_seq_number = bin (tape_label.tape_number, 17);
						/* start with restart tape# */
	if si.tape_seq_number < si.last_tape_number then do;
						/* current region continues on next tape */
	     si.next_tape_number = si.tape_seq_number + 1;
	     goto display_premount;
	end;
	si.next_tape_number = LARGE_TAPE_NUMBER;	/* start very high */
	do temp_pvx = si.pvx to si.pv_count;
	     do info_volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size
		while (info_tape_label.vol_array (info_volx).pvname ^= pv_array (temp_pvx).name);
	     end;
	     if pv_array (temp_pvx).only_part then do;
		do temp_partx = pv_array (temp_pvx).part_idx repeat part_array (temp_partx).next_idx
		     while (temp_partx ^= 0);
		     if ^part_array (temp_partx).complete then do;
			do rx = lbound (info_tape_label.vol_array (info_volx).region, 1)
			     to info_tape_label.vol_array (info_volx).nregions
			     while (info_tape_label.vol_array (info_volx).region (rx).part_name
			     ^= part_array (temp_partx).name);
			end;
			if info_tape_label.vol_array (info_volx).region (rx).begins_on_tape > si.tape_seq_number
			then if info_tape_label.vol_array (info_volx).region (rx).begins_on_tape
				< si.next_tape_number
			     then si.next_tape_number =
				     info_tape_label.vol_array (info_volx).region (rx).begins_on_tape;
			     else ;
			else if info_tape_label.vol_array (info_volx).region (rx).ends_on_tape > si.tape_seq_number
			then if info_tape_label.vol_array (info_volx).region (rx).ends_on_tape < si.next_tape_number
			     then si.next_tape_number =
				     max (info_tape_label.vol_array (info_volx).region (rx).begins_on_tape + 1,
				     si.tape_seq_number + 1);
			     else ;
			if si.next_tape_number = si.tape_seq_number + 1 then goto display_premount;
						/* can't get much closer */
		     end;
		end;
	     end;
	     else do;
		do rx = lbound (info_tape_label.vol_array (info_volx).region, 1)
		     to info_tape_label.vol_array (info_volx).nregions
		     while (info_tape_label.vol_array (info_volx).region (rx).part_name ^= "");
		end;
		if info_tape_label.vol_array (info_volx).region (rx).begins_on_tape > si.tape_seq_number
		then if info_tape_label.vol_array (info_volx).region (rx).begins_on_tape < si.next_tape_number
		     then si.next_tape_number = info_tape_label.vol_array (info_volx).region (rx).begins_on_tape;
		     else ;
		else if info_tape_label.vol_array (info_volx).region (rx).ends_on_tape > si.tape_seq_number
		then if info_tape_label.vol_array (info_volx).region (rx).ends_on_tape < si.next_tape_number
		     then si.next_tape_number =
			     max (info_tape_label.vol_array (info_volx).region (rx).begins_on_tape + 1,
			     si.tape_seq_number + 1);
		     else ;
		if si.next_tape_number = si.tape_seq_number + 1 then goto display_premount;
						/* can't get much closer */
	     end;
	end;
	if si.next_tape_number = LARGE_TAPE_NUMBER | si.next_tape_number <= si.tape_seq_number then do;
	     si.next_tape_number = si.tape_seq_number + 1;/* assume next # in sequence */
	     return;
	end;
display_premount:
	if si.usable_tape_devices > 1
	then call syserr (ANNOUNCE, "^a(^a): Please pre-mount tape# ^d on ^a.", my_name, si.tape_set,
		si.next_tape_number, FIND_NEXT_TAPE_DEVICE ());
	return;
%page;
/**** Entry that is called to read and validate a volume label.  If
      doing a restore, then several checks are also made between the
      volume label and the volume info contained in the tape label. */

bce_save_util_$read_pv_label:
     entry (a_sri_ptr);

	call SETUP;
read_pv_label:
	call read_disk ((pv.pvtx), (LABEL_ADDR), vol_preamblep, code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Could not read label of ^a on ^a.^66t***^/^-", my_name, pv.name,
		pv.device);
disk_error_query:
	     call bce_query (opr_input, "^a(^a): Do you want to retry or remove the pv? ", my_name, si.tape_set);
	     if opr_input = "retry" then goto read_pv_label;
	     else if opr_input ^= "remove" then do;
		call ioa_ ("^a(^a): Invalid input ""^a"". Must be ""retry"" or ""remove"".", my_name, si.tape_set,
		     opr_input);
		goto disk_error_query;
	     end;
	     pv.removed = YES;
	     return;
	end;
	if vol_preamble.Multics ^= Multics_ID_String then do;
	     call syserr (ANNOUNCE, "^a(^a): Volume on ^a is not a ^a.^[^;^66t***^/^-Removing from PV list.^]", my_name,
		si.tape_set, pv.device, Multics_ID_String, restoring);
	     if restoring then do;
		if pv.only_part then do;
		     call syserr (ANNOUNCE,
			"^a(^a): Unable to restore only partitions. Removing from PV list.^66t***", my_name,
			si.tape_set);
		     pv.removed = YES;
		end;
	     end;
	     else pv.removed = YES;
	     pv.real_name = pv.name;
	     return;
	end;
	call date_time_ (vol_preamble.time_map_updated, date_time_string);
	call ioa_ ("");
	call syserr (ANNOUNCE, "^a(^a): ^a ^a on ^a^/^2-Last updated: ^[Never Updated^s^;^a^]", my_name, si.tape_set,
	     Multics_ID_String, vol_preamble.pv_name, pv.device, (vol_preamble.time_map_updated = 0), date_time_string);
	pv.real_name = vol_preamble.pv_name;
	if pv.real_name ^= pv.name then do;
	     if restoring
	     then if ^pv.only_part
		then call syserr (ANNOUNCE, "^a(^a): Volume ^a will become ^a, as requested.^66t***", my_name,
			si.tape_set, vol_preamble.pv_name, pv.name);
		else ;
	     else do;
		call syserr (ANNOUNCE, "^a(^a): Volume was expected to be ^a. Removing from PV list.^66t***", my_name,
		     si.tape_set, pv.name);
		pv.removed = YES;
		return;
	     end;
	end;

	if ^restoring & pv.all_parts then do;
	     call bce_save_util_$setup_all_parts (srip);
	     if pv.removed then return;
	end;
	if pv.part_requested & (^restoring | pv.only_part) then do;
						/* only do when saving, or restoring only parts */
	     call SORT_PARTITION_LIST;
	     do partx = lbound (part_array, 1) to si.part_count;
						/* see if part defined */
		si.part_ptr, partp = addr (part_array (partx));
		if part.pv_name = pv.name & part.name ^= ALL_PARTS then do;
		     do i = lbound (vol_preamble.parts, 1) to vol_preamble.nparts
			while (vol_preamble.parts (i).part ^= part.name);
		     end;
		     if i > vol_preamble.nparts
		     then part.removed, part.complete = YES;
						/* part not on volume */
		     else do;
			part.frec = vol_preamble.parts (i).frec;
			part.lrec = vol_preamble.parts (i).frec + vol_preamble.parts (i).nrec - 1;
			part.nrec = vol_preamble.parts (i).nrec;
			if pv.restart.rec_on_pv > part.lrec then part.complete = YES;
			call ioa_ ("^- Partition ^4a:^2x^6d^2xfor^x^5d records^[ (^ad)^;^s^]", part.name, part.frec,
			     part.nrec, part.complete, my_name);
		     end;
		end;
	     end;
	     do partx = lbound (part_array, 1) to si.part_count;
						/* report about any that were removed */
		if part_array (partx).pv_name = pv.name & part_array (partx).removed
		then call syserr (ANNOUNCE,
			"^a(^a): Partition ^a is not defined on ^a.^66t***^/^-Removing from partition list.",
			my_name, si.tape_set, part_array (partx).name, vol_preamble.pv_name);
	     end;
	     if pv.only_part then do;
		do partx = lbound (part_array, 1) to si.part_count
		     while (part_array (partx).pv_name ^= pv.name | part_array (partx).removed);
		end;
		if partx > si.part_count then do;
		     call syserr (ANNOUNCE,
			"^a(^a): Removing volume ^a from PV list,^66t***^/^-because all partitions were removed.",
			my_name, si.tape_set, pv.name);
		     pv.removed = YES;
		     return;
		end;
	     end;
	end;

	if restoring then do;
	     do volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size
		while (info_tape_label.vol_array (volx).pvname ^= pv.name);
	     end;
	     if volx > info_tape_label.vol_array_size then do;
		call syserr (ANNOUNCE, "^a(^a): Volume ^a not found in tape label.^66t***^/^-Removing from PV list.",
		     my_name, si.tape_set, pv.name);
		pv.removed = YES;
		return;
	     end;
	     si.vol_info_ptr, vol_infop = addr (info_tape_label.vol_array (volx));
	     if pv.part_requested then do;
		call SORT_PARTITION_LIST;
		do partx = lbound (part_array, 1) to si.part_count;
						/* see if part defined */
		     if part_array (partx).pv_name = pv.name & part_array (partx).name ^= ALL_PARTS then do;
			si.part_ptr, partp = addr (part_array (partx));
			do i = lbound (vol_info.region, 1) to vol_info.nregions
			     while (part.name ^= vol_info.region (i).part_name);
			end;
			if i > vol_info.nregions then do;
						/* part not found */
			     call syserr (ANNOUNCE,
				"^a(^a): Partition ^a on ^a was not saved.^66t***^/^-Removing from partition list.",
				my_name, si.tape_set, part.name, pv.name);
			     part.removed, part.complete = YES;
			end;
		     end;
		end;
	     end;
	     if pv.only_part then do;
		if vol_info.data_saved = PV_ONLY then do;
		     call syserr (ANNOUNCE,
			"^a(^a): No partitions were saved for volume ^a.^66t***^/^-Removing from PV list.", my_name,
			si.tape_set, vol_info.pvname);
		     pv.removed = YES;
		end;
		return;
	     end;
	     if vol_info.data_saved = PART_ONLY then do;
		call syserr (ANNOUNCE,
		     "^a(^a): Only partitions were saved for volume ^a.^66t***^/^-Removing from PV list.", my_name,
		     si.tape_set, vol_info.pvname);
		pv.removed = YES;
		return;
	     end;
	     if ^pv.only_part & (vol_info.dev_type ^= pvt_array (pv.pvtx).device_type) then do;
		call syserr (ANNOUNCE,
		     "^a(^a): Device type mis-match. ^a is on a ^a,^66t***^/^-but was saved from a ^a. Removing from PV list.",
		     my_name, si.tape_set, pv.name, device_names (pvt_array (pv.pvtx).device_type),
		     device_names (vol_info.dev_type));
		pv.removed = YES;
	     end;
	     return;
	end;

/* Doing Save */
/* check label times */

	if ^pv.all then do;
	     if vol_preamble.time_map_updated = vol_preamble.time_unmounted then goto label_ok;
	     if vol_preamble.time_map_updated = vol_preamble.time_salvaged
		& vol_preamble.time_map_updated > vol_preamble.time_unmounted
	     then goto label_ok;
	     call syserr (ANNOUNCE,
		"^a(^a): Volume ^a requires salvaging.^66t***^/^-Setting -all to save all paging records on the volume.",
		my_name, si.tape_set, pv.name);
	     pv.all = YES;
	end;
label_ok:
	if pv.name = "rpv" then do;
	     do partx = lbound (part_array, 1) to si.part_count
		while (part_array (partx).pv_name ^= pv.name | part_array (partx).name ^= "conf");
	     end;
	     if partx > si.part_count
	     then call syserr (ANNOUNCE, "^a(^a): The ""conf"" partition of rpv is not being saved.^66t***", my_name,
		     si.tape_set);
	     do partx = lbound (part_array, 1) to si.part_count
		while (part_array (partx).pv_name ^= pv.name | part_array (partx).name ^= "file");
	     end;
	     if partx > si.part_count
	     then call syserr (ANNOUNCE, "^a(^a): The ""file"" partition of rpv is not being saved.^66t***", my_name,
		     si.tape_set);
	     do partx = lbound (part_array, 1) to si.part_count
		while (part_array (partx).pv_name ^= pv.name | part_array (partx).name ^= "log");
	     end;
	     if partx > si.part_count
	     then call syserr (ANNOUNCE, "^a(^a): The ""log"" partition of rpv is not being saved.^66t***", my_name,
		     si.tape_set);
	end;

/* Now fill in some of the volume info */

	if si.restart then do;
	     do volx = lbound (tape_label.vol_array, 1) to tape_label.vol_array_size
		while (tape_label.vol_array (volx).pvname ^= pv.name);
	     end;
	     if volx > tape_label.vol_array_size then do;
		call syserr (ANNOUNCE,
		     "^a(^a): Volume ^a not found in restart tape label.^66t***^/^-Removing from PV list.", my_name,
		     si.tape_set, pv.name);
		pv.removed = YES;
		return;
	     end;
	     si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (volx));
	     if vol_info.pvid ^= vol_preamble.pvid then do;
		call syserr (ANNOUNCE,
		     "^a(^a): Volume ^a's PVID does not match^66t***^/^-the one in the restart tape label. Removing from PV list.",
		     my_name, si.tape_set, pv.name);
		pv.removed = YES;
		return;
	     end;
	     if (pv.only_part & vol_info.data_saved ^= PART_ONLY)
		| (^pv.part_requested & vol_info.data_saved = BOTH_SAVED) then do;
		call syserr (ANNOUNCE,
		     "^a(^a): Type of data being saved for volume ^a^66t***^/^-does not match the type in the restart tape label.^/^-Removing from PV list.",
		     my_name, si.tape_set, pv.name);
		pv.removed = YES;
		return;
	     end;
	     do partx = lbound (part_array, 1) to si.part_count;
		if part_array (partx).pv_name = vol_info.pvname then do;
		     do i = lbound (vol_info.region, 1) to vol_info.nregions
			while (vol_info.region (i).part_name ^= part_array (partx).name);
		     end;
		     if i > vol_info.nregions then do;
			call syserr (ANNOUNCE,
			     "^a(^a): Partition ^a of volume ^a^66t***^/^-is not defined in the restart tape label. Removing from PV list.",
			     my_name, si.tape_set, part_array (partx).name, vol_info.pvname);
			pv.removed = YES;
			return;
		     end;
		end;
	     end;
	end;
	else do;					/* normal path */
	     tape_label.vol_array_size = tape_label.vol_array_size + 1;
	     si.vol_info_ptr, vol_infop = addr (tape_label.vol_array (tape_label.vol_array_size));
	     si.first_rec, si.last_rec, vol_info.restart.rec_on_pv, vol_info.restart.rec_in_type = -1;
	     vol_info.pvname = vol_preamble.pv_name;
	     vol_info.pvid = vol_preamble.pvid;
	     if pv.only_part then vol_info.data_saved = PART_ONLY;
	     else if pv.part_requested then vol_info.data_saved = BOTH_SAVED;
	     else vol_info.data_saved = PV_ONLY;
	     vol_info.dev_type = pvt_array (pv.pvtx).device_type;
	     vol_info.nregions = 0;
	     if ^pv.only_part then do;		/* define vtoc/paging region */
		vol_info.nregions = vol_info.nregions + 1;
		vol_info.region (vol_info.nregions).part_name = "";
		vol_info.region (vol_info.nregions).begins_on_tape = 0;
		vol_info.region (vol_info.nregions).ends_on_tape = 0;
	     end;
	     do partx = lbound (part_array, 1) to si.part_count;
		if part_array (partx).pv_name = pv.name & ^part_array (partx).removed then do;
		     vol_info.nregions = vol_info.nregions + 1;
		     vol_info.region (vol_info.nregions).part_name = part_array (partx).name;
		     vol_info.region (vol_info.nregions).begins_on_tape = 0;
		     vol_info.region (vol_info.nregions).ends_on_tape = 0;
		end;
	     end;
	     vol_info.current_region = 1;
	end;
	return;
%page;
/**** Entry to read and parse save/restore control files that are kept in
      the FILE partition on the RPV. */

bce_save_util_$scan_control_file:
     entry (a_sri_ptr);
dcl	cf		char (cf_len) based (cf_ptr);
dcl	cf_arg		char (cf_arg_lth) based (cf_arg_ptr);
dcl	cf_arg_lth	fixed bin;
dcl	cf_arg_ptr	ptr;
dcl	1 cf_array	(32) aligned based (cf_array_ptr) like cf_info;
dcl	cf_array_ptr	ptr;
dcl	cf_idx		fixed bin (21);
dcl	cf_len		fixed bin (21);
dcl	cf_line		char (256) varying;
dcl	cf_line_start	fixed bin;
dcl	cf_ptr		ptr;
dcl	chk_start		fixed bin;
dcl	expect_cf_arg	bit (1);
dcl	have_cf_arg	bit (1);
dcl	line_count	fixed bin;
dcl	nl_idx		fixed bin;
dcl	part_device	char (8);
dcl	part_pv_name	char (32);
dcl	temp_pvtx		fixed bin (17);

	call SETUP;
	cf_array_ptr = sri.cf_arrayp;
	call bootload_fs_$get_ptr ((cf_array (sri.cfx).name), cf_array (sri.cfx).ptr, cf_array (sri.cfx).length, code);
	if code ^= 0 then do;
	     call syserr$error_code (BEEP, code, "^a: Initiating ^a for set-^d^66t***^/^-", my_name,
		cf_array (sri.cfx).name, setx);
	     call ABORT;
	end;
	cf_ptr = cf_array (sri.cfx).ptr;
	cf_len = cf_array (sri.cfx).length;
	cf_idx = 1;
	line_count = 0;
	do while (cf_idx < cf_len);
	     nl_idx = index (substr (cf, cf_idx), NL);
	     if nl_idx = 0 then do;
		call ioa_ ("^a: Line ^d of ^a does not end with a line_feed character.", my_name, line_count + 1,
		     cf_array (sri.cfx).name);
		call ABORT;
	     end;
	     line_count = line_count + 1;
	     cf_line = ltrim (rtrim (substr (cf, cf_idx, nl_idx), BREAKS), BREAKS);
	     cf_arg_ptr = addr (cf_line);
	     cf_line_start = 1;
	     have_cf_arg = YES;
	     if index (COMMENT_CHARS, substr (cf_line, 1, 1)) > 0 then have_cf_arg = NO;
						/* skip comment line */
	     expect_cf_arg = YES;
	     do while (have_cf_arg);
		call GET_CF_ARG;
		if ^have_cf_arg then goto end_cf_arg_scan;
		if ^expect_cf_arg then do;
		     call ioa_ ("^a: Invalid argument ""^a""^/^-at line ^d of ^a for set-^[^a^s^;^s^d^].", my_name,
			cf_arg, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
		     call ABORT;
		end;

/**** tape_set, ts TAPE_SET_NAME */

		if cf_arg = "tape_set" | cf_arg = "ts" then do;
		     if si.tape_set ^= "" then do;
			call ioa_ ("^a: Attempt to multiply define tape set name ""^a""^/^-at line ^d of ^a.",
			     my_name, si.tape_set, line_count, cf_array (sri.cfx).name);
			call ABORT;
		     end;
		     call GET_CF_ARG;		/* get tape set name */
		     if ^have_cf_arg then do;
bad_ts_arg:
			call ioa_ ("^a: Invalid tape_set request at line ^d of ^a.", my_name, line_count,
			     cf_array (sri.cfx).name);
			call ABORT;
		     end;
		     if cf_arg_lth > length (si.tape_set) then goto bad_ts_arg;
		     do i = lbound (set_info, 1) to setx - 1;
						/* check for multiple definitions */
			if set_info (i).tape_set = cf_arg then do;
			     call ioa_ ("^a: Tape set ^a has been multiply defined^/^-at line ^d of ^a.", my_name,
				cf_arg, line_count, cf_array (sri.cfx).name);
			     call ABORT;
			end;
		     end;
		     si.tape_set = cf_arg;		/* now save name */
		     expect_cf_arg = NO;
		end;

/**** tape_device, td TAPE_DEVICE {-density N, -den N, density=N, den=N, d=N} */

		else if cf_arg = "tape_device" | cf_arg = "td" then do;
		     si.tape_count = si.tape_count + 1;
		     si.usable_tape_devices = si.usable_tape_devices + 1;
		     if si.tape_count > hbound (tcb_array, 1) then do;
			call ioa_ ("^a: Attempt to define more than ^d tape devices for set-^[^a^s^;^s^d^].",
			     my_name, hbound (tcb_array, 1), (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     si.tcb_ptr, tcbp = addr (tcb_array (si.tape_count));
		     unspec (tcb) = ""b;		/* start fresh */

		     call GET_CF_ARG;		/* get device name */
		     if ^have_cf_arg then do;
bad_td_arg:
			call ioa_ ("^a: Invalid tape_drive request at line ^d of ^a for set-^[^a^s^;^s^d^].",
			     my_name, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     if substr (cf_arg, 1, 3) ^= "tap" then goto bad_td_arg;
		     do i = lbound (set_info, 1) to setx;
						/* check for multiple definitions */
			do j = FIRST_TAPE_DEV_IDX to set_info (i).tape_count;
			     tcb_arrayp = addr (tcb_area (i, 0));
			     if tcb_array (j).name = cf_arg then do;
				call ioa_ ("^a: Device ^a has been multiply defined.", my_name, cf_arg);
				call ABORT;
			     end;
			end;
		     end;
		     tcb.name = cf_arg;		/* now save name */

		     call GET_CF_ARG;		/* get density, if available. */
		     if ^have_cf_arg then do;		/* no arg */
			if restoring
			then tcb.density = ANY_DENSITY;
						/* restore, allow any */
			else tcb.density = DEN6250;	/* save, default to 6250 */
			goto end_cf_arg_scan;
		     end;
		     if substr (cf_arg, 1, 2) = "-d" then do;
			call GET_CF_ARG;
			if ^have_cf_arg then goto bad_td_arg;
			if cf_arg = "6250" then tcb.density = DEN6250;
			else if cf_arg = "1600" then tcb.density = DEN1600;
			else if cf_arg = "800" then tcb.density = DEN800;
			else if cf_arg = "556" then tcb.density = DEN556;
			else goto bad_td_arg;
		     end;
		     else do;
			if after (cf_arg, "=") = "6250" then tcb.density = DEN6250;
			else if after (cf_arg, "=") = "1600" then tcb.density = DEN1600;
			else if after (cf_arg, "=") = "800" then tcb.density = DEN800;
			else if after (cf_arg, "=") = "556" then tcb.density = DEN556;
			else goto bad_td_arg;
		     end;
		     expect_cf_arg = NO;
		end;

/**** physical_volume, pv PV_NAME DEVICE_NAME {-all} */

		else if cf_arg = "physical_volume" | cf_arg = "pv" then do;
		     si.pv_count = si.pv_count + 1;
		     if si.pv_count > hbound (pv_array, 1) then do;
			call ioa_ ("^a: Attempt to ^a more than ^d physical volumes for set-^[^a^s^;^s^d^].",
			     my_name, my_name, hbound (pv_array, 1), (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     si.pv_ptr, pvp = addr (pv_array (si.pv_count));
		     unspec (pv) = ""b;		/* start fresh */

		     call GET_CF_ARG;		/* get pv_name */
		     if ^have_cf_arg then do;
bad_pv_arg:
			call ioa_ ("^a: Invalid pv request at line ^d of ^a for set-^[^a^s^;^s^d^].", my_name,
			     line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     if restoring
		     then chk_start = 1;		/* check all sets */
		     else chk_start = setx;		/* only check this set */
		     do i = chk_start to setx;
			pv_arrayp = addr (pv_area (i, 1));
			do j = lbound (pv_array, 1) to si.pv_count;
						/* check for multiple definitions */
			     if pv_array (j).name = cf_arg then do;
				call ioa_ (
				     "^a: PV ^a has been multiply defined at line ^d of ^a for set-^[^a^s^;^s^d^].",
				     my_name, cf_arg, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""),
				     si.tape_set, setx);
				call ABORT;
			     end;
			end;
		     end;
		     pv.name = cf_arg;		/* now save name */

		     call GET_CF_ARG;		/* get device name */
		     if ^have_cf_arg then goto bad_pv_arg;
		     if cf_arg_lth > 8 then goto bad_pv_arg;
		     pv.device = cf_arg;
		     call disk_name_pvtx ((pv.device), temp_pvtx, code);
		     if code ^= 0 then do;
			call com_err_ (code, my_name, pv.device);
			goto bad_pv_arg;
		     end;
		     pv.pvtx = temp_pvtx;
		     if ^restoring then do;
			call GET_CF_ARG;		/* check for -all */
			if ^have_cf_arg then pv.all = NO;
			else if cf_arg = "-all" | cf_arg = "-a" then pv.all = YES;
			else goto bad_pv_arg;
		     end;
		     pv.restart.rec_on_pv, pv.restart.rec_in_type = 0;
		     pv.only_part = NO;
		     pv.part_requested = NO;
		     pv.complete = NO;
		     pv.removed = NO;
		     expect_cf_arg = NO;
		end;

/**** partition, part PV_NAME DEVICE_NAME PART_NAME(-all) {PART_NAME ...} */

		else if cf_arg = "partition" | cf_arg = "part" then do;
		     call GET_CF_ARG;		/* get pv_name */
		     if ^have_cf_arg then do;
bad_part_arg:
			call ioa_ ("^a: Invalid part request at line ^d of ^a for set-^[^a^s^;^s^d^].", my_name,
			     line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     part_pv_name = cf_arg;		/* now save pv_name */

		     call GET_CF_ARG;		/* get device name */
		     if ^have_cf_arg then goto bad_part_arg;
		     if cf_arg_lth > 8 then goto bad_part_arg;
		     part_device = cf_arg;
		     call disk_name_pvtx (part_device, temp_pvtx, code);
		     if code ^= 0 then do;
			call com_err_ (code, my_name, part_device);
			goto bad_part_arg;
		     end;

		     call GET_CF_ARG;		/* get part_name */
		     if ^have_cf_arg then goto bad_part_arg;
						/* must have at least one */
		     do while (have_cf_arg);
			si.part_count = si.part_count + 1;
			if si.part_count > hbound (part_array, 1) then do;
			     call ioa_ ("^a: Attempt to ^a more than ^d partitions for set-^[^a^s^;^s^d^].",
				my_name, my_name, hbound (part_array, 1), (si.tape_set ^= ""), si.tape_set, setx);
			     call ABORT;
			end;
			si.part_ptr, partp = addr (part_array (si.part_count));
			unspec (part) = ""b;	/* start fresh */
			part.pv_name = part_pv_name;	/* save pv_name */
			part.device = part_device;
			part.pv_pvtx = temp_pvtx;

			if cf_arg = "alt" | cf_arg = "hc" then do;
			     call ioa_ ("^a: Not allowed to ^a the ""^a"" partition.", my_name, my_name, cf_arg);
			     goto bad_part_arg;
			end;
			if part.pv_name = "rpv" & cf_arg = "bce" then do;
			     call ioa_ ("^a: Not allowed to ^a the ""bce"" partition of the RPV.", my_name, my_name)
				;
			     goto bad_part_arg;
			end;
			if restoring
			then chk_start = 1;		/* check all sets */
			else chk_start = setx;	/* only check this set */
			if cf_arg = ALL_PARTS
			then doing_all_parts = YES;
			else doing_all_parts = NO;
			do i = chk_start to setx;
			     part_arrayp = addr (part_area (i, 1));
			     part_entries = 0;
			     do j = lbound (part_array, 1) to si.part_count;
				if part_array (j).pv_name = part.pv_name then do;
				     part_entries = part_entries + 1;
				     if part_array (j).name = ALL_PARTS then doing_all_parts = YES;
						/* check for multiple definitions */
				     if part_array (j).name = cf_arg then do;
					call ioa_ (
					     "^a: Partition ^a of ^a has been multiply defined at line ^d of ^a for set-^[^a^s^;^s^d^].",
					     my_name, cf_arg, part.pv_name, line_count, cf_array (sri.cfx).name,
					     (si.tape_set ^= ""), si.tape_set, setx);
					call ABORT;
				     end;
				end;
			     end;
			     if doing_all_parts & part_entries > 1 then do;
				call ioa_ (
				     "^a: Invalid partition request at line ^d of ^a for set-^[^a^s^;^s^d^].^/^-No other partition names can be given when ""-all"" is used.",
				     my_name, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""),
				     si.tape_set, setx);
				call ABORT;
			     end;
			end;
			part.name = cf_arg;
			if PARTITION_COUNT (part.pv_name) > MAX_PARTS_PER_VOL then do;
			     call ioa_ ("^a: Attempt to ^a more than ^d partitions per volume for ^a.", my_name,
				my_name, MAX_PARTS_PER_VOL, part.pv_name);
			     call ABORT;
			end;
			part.complete = NO;
			part.removed = NO;
			part.frec, part.lrec, part.nrec = -1;
			part.tfrec, part.tlrec, part.tnrec = -1;

			call GET_CF_ARG;		/* get next part name */
		     end;
		     expect_cf_arg = NO;
		end;

/**** control_file, cf CONTROL_FILE_NAME */

		else if cf_arg = "control_file" | cf_arg = "cf" then do;
		     call GET_CF_ARG;
		     if ^have_cf_arg then do;
			call ioa_ (
			     "^a: No file given for control_file request at line ^d of ^a for set-^[^a^s^;^s^d^].",
			     my_name, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
			call ABORT;
		     end;
		     sri.cf_count = sri.cf_count + 1;	/* extend control file array */
		     if sri.cf_count > hbound (cf_array, 1) then do;
			call ioa_ ("^a: Attempt to process more than ^d control files.", my_name,
			     hbound (cf_array, 1));
			call ABORT;
		     end;
		     if cf_arg_lth > length (cf_array (1).name) then do;
			call ioa_ ("^a: Illegal control file name ""^a"" on line ^d of ^a for set-^[^a^s^;^s^d^].",
			     my_name, cf_arg, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set,
			     setx);
			call ABORT;
		     end;
		     unspec (cf_array (sri.cf_count)) = ""b;
		     do i = lbound (cf_array, 1) to sri.cf_count - 1
			while (cf_array (i).name ^= cf_arg | (cf_array (i).set ^= setx & ^restoring));
		     end;
		     if i ^= sri.cf_count then do;
			call ioa_ (
			     "^a: Control file ""^a"" has be multiply specified on line ^d of ^a for set-^[^a^s^;^s^d^].",
			     my_name, cf_arg, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set,
			     setx);
			call ABORT;
		     end;
		     cf_array (i).name = cf_arg;
		     cf_array (i).set = setx;
		     cf_array (i).length = 0;
		     cf_array (i).ptr = null ();
		     expect_cf_arg = NO;
		end;
		else do;
		     call ioa_ ("^a: Invalid request ""^a""^/^-at line ^d of ^a for set-^[^a^s^;^s^d^].", my_name,
			cf_arg, line_count, cf_array (sri.cfx).name, (si.tape_set ^= ""), si.tape_set, setx);
		     call ABORT;
		end;
end_cf_arg_scan:
	     end;
next_cf_line:
	     cf_idx = cf_idx + nl_idx;		/* skip to next line */
	end;
	return;
%page;
/**** This entry is used to scan the tape device survey data, returned
      by the tape controller. Then extract the speed and densities available.
      a_tcbp is required because we may have switched to the controller tcb
      to do the survey but need to reference the device tcb. */

bce_save_util_$scan_survey_data:
     entry (a_sri_ptr, a_tcbp);
dcl	a_tcbp		ptr;

	call SETUP;
	do i = lbound (survey_ws.handler, 1) to hbound (survey_ws.handler, 1);
	     if unspec (survey_ws.data.handler (i)) ^= ""b & survey_ws.data.handler (i).number = a_tcbp -> tcb.device
	     then goto found_device;
	end;
	call syserr$error_code (BEEP, error_table_$no_device, "^a: ^a", my_name, a_tcbp -> tcb.name);
	return;

found_device:
	if ^survey_ws.data.handler (i).operational then do;
	     call syserr$error_code (BEEP, error_table_$device_not_usable, "^a: ^a", my_name, a_tcbp -> tcb.name);
	     return;
	end;

	a_tcbp -> tcb.densities_available = density_table (survey_ws.data.handler (i).density);
	if a_tcbp -> tcb.write_tape & (a_tcbp -> tcb.densities_available & a_tcbp -> tcb.density) = ""b then do;
						/* density not available */
	     call syserr$error_code (BEEP, error_table_$bad_density, "^a: ^a", my_name, a_tcbp -> tcb.name);
	     return;
	end;
	density_idx = index (a_tcbp -> tcb.density, ON);
	a_tcbp -> tcb.density_command = density_commands (density_idx);

	a_tcbp -> tcb.speed = speed_table (survey_ws.data.handler (i).speed);
	if a_tcbp -> tcb.speed = ""b then do;		/* something is amiss */
	     call syserr$error_code (BEEP, error_table_$incorrect_device_type, "^a: ^a", my_name, a_tcbp -> tcb.name);
	     return;
	end;
	a_tcbp -> tcb.surveyed = YES;
	return;
%page;
/**** Entry to create entries in the part_array when "-all" was
      given in the part request. When saving, the info comes from the
      vol_preamble. When restoring, the info comes from the info_tape_label. */

bce_save_util_$setup_all_parts:
     entry (a_sri_ptr);

	call SETUP;
	if restoring then do;
	     do volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size
		while (info_tape_label.vol_array (volx).pvname ^= pv.name);
	     end;
	     if volx > info_tape_label.vol_array_size then return;
						/* volume not defined */
	     si.vol_info_ptr, vol_infop = addr (info_tape_label.vol_array (volx));
	     if vol_info.data_saved = PV_ONLY then do;
		if pv.only_part then do;		/* game over for this PV */
		     call syserr (ANNOUNCE,
			"^a(^a): No partitions were saved for volume ^a.^66t***^/^-Removing from PV list.", my_name,
			si.tape_set, vol_info.pvname);
		     pv.removed = YES;
		end;
		return;
	     end;
	     do i = lbound (vol_info.region, 1) to vol_info.nregions;
		if vol_info.region (i).part_name ^= "" then do;
		     do partx = lbound (part_array, 1) to si.part_count
			while (part_array (partx).pv_name ^= pv.name
			| part_array (partx).name ^= vol_info.region (i).part_name);
			if part_array (partx).pv_name = pv.name & part_array (partx).name = ALL_PARTS then do;
			     si.part_ptr, partp = addr (part_array (partx));
			     goto fill_in_part_entry_for_restore;
						/* reuse this entry */
			end;
		     end;
		     if partx > si.part_count then do;	/* need to add */
			if partx > hbound (part_array, 1)
			then call syserr (ANNOUNCE,
				"^a(^a): Unable to ^a ""^a"" partition.^66t***^/^-Internal partition list full.",
				my_name, si.tape_set, my_name, vol_preamble.parts (i).part);
			else if PARTITION_COUNT (pv.name) = MAX_PARTS_PER_VOL
			then call syserr (ANNOUNCE,
				"^a(^a): Unable to ^a ""^a"" partition.^66t***^/^-^d partitions already defined",
				my_name, si.tape_set, my_name, vol_preamble.parts (i).part, MAX_PARTS_PER_VOL);
			else do;
			     si.part_count = partx;
			     si.part_ptr, partp = addr (part_array (si.part_count));
fill_in_part_entry_for_restore:
			     unspec (part) = ""b;
			     part.name = vol_info.region (i).part_name;
			     part.pv_name = pv.name;
			     part.device = pv.device;
			     part.pv_pvtx = pv.pvtx;
			     part.complete = NO;
			     part.removed = NO;
			     part.frec, part.lrec, part.nrec = -1;
			     part.tfrec, part.tlrec, part.tnrec = -1;
			end;
		     end;
		end;
	     end;
	end;
	else do;					/* doing a save */
	     part_entries = 0;
	     do i = lbound (vol_preamble.parts, 1) to vol_preamble.nparts;
		if vol_preamble.parts (i).part ^= "alt" & vol_preamble.parts (i).part ^= "bce"
		     & vol_preamble.parts (i).part ^= "hc" then do;
		     do partx = lbound (part_array, 1) to si.part_count
			while (part_array (partx).pv_name ^= pv.name
			| part_array (partx).name ^= vol_preamble.parts (i).part);
			if part_array (partx).pv_name = pv.name & part_array (partx).name = ALL_PARTS then do;
			     si.part_ptr, partp = addr (part_array (partx));
			     goto fill_in_part_entry_for_save;
						/* reuse this entry */
			end;
		     end;
		     if partx > si.part_count then do;	/* need to add */
			if partx > hbound (part_array, 1)
			then call syserr (ANNOUNCE,
				"^a(^a): Unable to ^a ""^a"" partition.^66t***^/^-Internal partition list full.",
				my_name, si.tape_set, my_name, vol_preamble.parts (i).part);
			else if PARTITION_COUNT (pv.name) = MAX_PARTS_PER_VOL
			then call syserr (ANNOUNCE,
				"^a(^a): Unable to ^a ""^a"" partition.^66t***^/^-^d partitions already defined",
				my_name, si.tape_set, my_name, vol_preamble.parts (i).part, MAX_PARTS_PER_VOL);
			else do;
			     si.part_count = partx;
			     si.part_ptr, partp = addr (part_array (si.part_count));
fill_in_part_entry_for_save:
			     unspec (part) = ""b;
			     part.name = vol_preamble.parts (i).part;
			     part.pv_name = pv.name;
			     part.device = pv.device;
			     part.pv_pvtx = pv.pvtx;
			     part.complete = NO;
			     part.removed = NO;
			     part.frec = vol_preamble.parts (i).frec;
			     part.lrec = vol_preamble.parts (i).frec + vol_preamble.parts (i).nrec - 1;
			     part.nrec = vol_preamble.parts (i).nrec;
			     part.tfrec, part.tlrec, part.tnrec = -1;
			end;
		     end;
		     part_entries = part_entries + 1;
		end;
	     end;
	     if part_entries = 0 then do;
		if pv.only_part then do;
		     call syserr (ANNOUNCE,
			"^a(^a): Removing volume ^a from PV list,^66t***^/^-because there are no partitions to save.",
			my_name, si.tape_set, pv.name);
		     pv.removed = YES;
		     return;
		end;
		call syserr (ANNOUNCE,
		     "^a(^a): Reverting ""-all"" partition request^66t***^/^-for volume ^a, because there are no partitions to save.",
		     my_name, si.tape_set, pv.name);
		pv.part_requested, pv.all_parts = NO;
		return;
	     end;
	end;
	call SORT_PARTITION_LIST;
	return;
%page;
/**** Entry that is called after a time-out waiting for a tape mount.
      That asks if the current device should be skipped and the next
      device in the list be used.  It might be that the current device is
      defective and the tape cannot be mounted. */

bce_save_util_$skip_tape_device:
     entry (a_sri_ptr) returns (bit (1));

	call SETUP;
skip_query:
	call bce_query (opr_input, "^a(^a): Would you like to skip to the next tape device?", my_name, si.tape_set);
	if opr_input = "yes" | opr_input = "y" then return (YES);
	else if opr_input = "no" | opr_input = "n" then return (NO);
	else if opr_input = "remove" then do;
	     if si.usable_tape_devices = 1 then do;
		call ioa_ ("^a(^a): Unable to remove ^a. This is the last device.", my_name, si.tape_set, tcb.name);
		goto skip_query;
	     end;
	     tcb.removed = YES;			/* remove & */
	     si.usable_tape_devices = si.usable_tape_devices - 1;
	     return (YES);				/* skip device */
	end;
	else if opr_input = "help" | opr_input = "?" then do;
	     call ioa_ ("Valid inputs are:");
	     call ioa_ ("yes, y^21t- Skip this device and go to next.");
	     call ioa_ ("no, n^21t- Continue to use this device.");
	     call ioa_ ("remove^21t- Remove this device, skip to next.");
	     goto skip_query;
	end;
	else do;
	     call ioa_ ("Invalid input ""^a"". Type ""help"" or ""?"" for valid inputs.", opr_input);
	     goto skip_query;
	end;
	return;
%page;
/**** This entry is used during a restore to get the PV list generated
      from processing the control files into the same order that the save
      tape label has them in.  This is necessary to allow sequential tape
      processing. */

bce_save_util_$sort_pv_list:
     entry (a_sri_ptr);
dcl	pv_from_idx	fixed bin;
dcl	1 pv_hold_area	aligned like pv;
dcl	pv_to_idx		fixed bin;
dcl	temp_volx		fixed bin;

	call SETUP;
	pv_to_idx = 1;				/* start with first PV slot */
	do temp_volx = lbound (info_tape_label.vol_array, 1) to info_tape_label.vol_array_size;
	     do pv_from_idx = lbound (pv_array, 1) to si.pv_count;
		if pv_array (pv_from_idx).name = info_tape_label.vol_array (temp_volx).pvname then do;
		     pv_hold_area = pv_array (pv_to_idx);
						/* save current info */
		     pv_array (pv_to_idx) = pv_array (pv_from_idx);
						/* swap in new info */
		     pv_array (pv_from_idx) = pv_hold_area;
						/* replace with old */
		     pv_to_idx = pv_to_idx + 1;
		     goto next_tape_vol;
		end;
	     end;
next_tape_vol:
	end;
	return;
%page;
/**** Entry to connect all the non-removed partitions for a given
      pv into a threaded list.  Then the part_idx in the pv entry is
      setup to point to the start of the list. */

bce_save_util_$thread_partition_list:
     entry (a_sri_ptr);
dcl	first_part_idx	fixed bin;
dcl	prev_part_idx	fixed bin;

	call SETUP;
	do si.pvx = lbound (pv_array, 1) to si.pv_count;
	     si.pv_ptr, pvp = addr (pv_array (si.pvx));
	     if pv.part_requested then do;
		prev_part_idx = -1;
		do partx = lbound (part_array, 1) to si.part_count;
		     if part_array (partx).pv_name = pv.name & ^part_array (partx).removed then do;
			if prev_part_idx > 0
			then part_array (prev_part_idx).next_idx = partx;
			else first_part_idx = partx;
			part_array (partx).next_idx = 0;
			prev_part_idx = partx;
		     end;
		end;
		pv.part_idx = first_part_idx;
	     end;
	end;
	return;
%page;
/**** ABORT - Routine to force program termination and cleanup to be done. */

ABORT:
     procedure;

	signal sub_request_abort_;
	return;
     end ABORT;
%page;
/**** Routine to check if an outstanding disk I/O has completed. Returns
      YES or NO based on the results.

      NOTE: This routine is duplicated in bce_save.pl1 to save having to
      push a stack frame. */

DISK_DATA_READY:
     procedure () returns (bit (1));

	if iob.state = DISK_READY then return (YES);
	call bootload_disk_io$test_done (iob.disk_post_buf, code);
	if code = error_table_$not_done then return (NO);
	if code ^= 0 then do;			/* until something better */
	     call syserr$error_code (BEEP, code, "^a: ^a", my_name, pv.name);
	     call ABORT;
	end;
	iob.state = DISK_READY;
	iob.state_time = clock ();
	return (YES);
     end DISK_DATA_READY;
%page;
/**** Procedure to find the next tape device to be used and return
      its name. */

FIND_NEXT_TAPE_DEVICE:
     procedure () returns (char (8));
dcl	temp_tcbx		fixed bin;

	do temp_tcbx = si.tcbx + 1 to si.tape_count while (tcb_array (temp_tcbx).removed);
	end;
	if temp_tcbx > si.tape_count then do;		/* wrap around */
	     do temp_tcbx = FIRST_TAPE_DEV_IDX to si.tape_count while (tcb_array (temp_tcbx).removed);
	     end;
	     if temp_tcbx > si.tape_count then return ("????");
	end;
	return (tcb_array (temp_tcbx).name);
     end FIND_NEXT_TAPE_DEVICE;
%page;
/**** Small routine to mark an I/O buffer as free.

      NOTE: This routine is duplicated in bce_save.pl1 to save having to
      push a stack frame. */

FREE_BUFFER:
     procedure;

	iob.state = FREE;
	iob.state_time = clock ();
	return;
     end FREE_BUFFER;
%page;
/**** This procedure is used to locate the next argument in a line.
      If one is found a pointer, length and flag are set. Otherwise
      the flag is reset, which will be used to sequence to the next
      line. */

GET_CF_ARG:
     procedure;

	if cf_line_start > length (cf_line) then do;
	     have_cf_arg = NO;
	     return;
	end;
	cf_arg_lth = search (substr (cf_line, cf_line_start), BREAKS) - 1;
	if cf_arg_lth = -1 then cf_arg_lth = length (cf_line) - cf_line_start + 1;

	if cf_arg_lth = 0 then do;
	     have_cf_arg = NO;
	     return;
	end;
	cf_arg_ptr = addr (substr (cf_line, cf_line_start));
	cf_line_start = cf_line_start + cf_arg_lth + 1;
	have_cf_arg = YES;
	return;
     end GET_CF_ARG;
%page;
/**** Routine to locate a free I/O buffer and mark it as suspended for
      disk I/O.  The caller must have previously called BUFFER_AVAILABLE
      so that the routine does not abort when none can be found.

      NOTE: This routine is duplicated in bce_save.pl1 to save having to
      push a stack frame. */

GET_DISK_BUFFER:
     procedure;

	do iobp = ptr (tcb.wksp, tcb.buf_listx) repeat ptr (tcb.wksp, iob.next_bufx) while (rel (iobp) ^= ""b);
	     if iob.state = FREE then do;
		iob.state = DISK_SUSPEND;
		iob.state_time = clock ();
		iob.next_statex = 0;
		si.datap = ptr (tcb.wksp, iob.datax);
		return;
	     end;
	end;
	call syserr (CRASH, "bce_save_util_: Out of disk buffers for ^a.", si.tape_set);
     end GET_DISK_BUFFER;
%page;
/**** Procedure to find the number of requested partitions for a given
      volume. The threads are not used, as they may not be setup. */

PARTITION_COUNT:
     procedure (p_pvname) returns (fixed bin);
dcl	p_pvname		char (32) aligned parm;
dcl	part_count_for_vol	fixed bin;

	part_count_for_vol = 0;
	do temp_partx = lbound (part_array, 1) to si.part_count;
	     if part_array (temp_partx).pv_name = p_pvname then part_count_for_vol = part_count_for_vol + 1;
	end;
	return (part_count_for_vol);
     end PARTITION_COUNT;
%page;
/**** Routine that take an I/O buffer that has been queued for a disk read
      and asks that it now take place.

      NOTE: This routine is duplicated in bce_save.pl1 to save having to
      push a stack frame. */

READ_DISK:
     procedure;

	iob.state = DISK_BUSY;
	iob.state_time = clock ();
	call bootload_disk_io$queue_read ((pv.pvtx), (iob.head.rec_on_pv), 1, ptr (tcb.wksp, iob.datax),
	     iob.disk_post_buf, code);
	return;
     end READ_DISK;
%page;
/**** Routine to setup the per-set pointers. */

SETUP:
     procedure;

	srip = a_sri_ptr;
	if sri.version_id ^= sri_version_1 then do;
	     call syserr$error_code (BEEP, error_table_$unimplemented_version, "^a: sri", my_name);
	     call ABORT;
	end;
	setx = sri.set_index;
	restoring = sri.doing_restore;
	my_name = sri.whoami;
	pvt_arrayp = sri.pvt_array_ptr;
	si_ptr = addr (set_info (setx));
	if si.version_id ^= si_version_1 then do;
	     call syserr$error_code (BEEP, error_table_$unimplemented_version, "^a: si", my_name);
	     call ABORT;
	end;
	iobp = null ();
	info_tape_labelp = si.info_tape_label_ptr;
	part_arrayp = addr (part_area (setx, 1));
	partp = si.part_ptr;
	pv_arrayp = addr (pv_area (setx, 1));
	pvp = si.pv_ptr;
	tape_labelp = si.tape_label_ptr;
	tcb_arrayp = addr (tcb_area (setx, 0));
	tcbp = si.tcb_ptr;
	vol_preamblep = si.vol_preamble_ptr;
	vol_infop = si.vol_info_ptr;
	return;
     end SETUP;
%page;
/**** This procedure is used during a save or restore to get the Partition
      list generated from processing the control files into an order that
      will match the way that they will be saved or restored.  This is
      necessary to allow sequential tape processing.  During a save the
      order is based on the physical position of the partition on the
      volume being saved.  During a restore the order is based on the
      sequence they are in the vol_info.regions array. */

SORT_PARTITION_LIST:
     procedure;
dcl	low_part_frec	fixed bin;
dcl	low_px		fixed bin;
dcl	part_from_idx	fixed bin;
dcl	1 part_hold_area	aligned like part;
dcl	part_to_idx	fixed bin;
dcl	px		fixed bin;
dcl	sort_done		bit (1);
dcl	water_mark	fixed bin;


	if restoring then do;
	     do part_to_idx = lbound (part_array, 1) to si.part_count
		while (part_array (part_to_idx).pv_name ^= pv.name);
						/* locate first partition */
	     end;
	     do rx = lbound (vol_info.region, 1) to vol_info.nregions;
		do part_from_idx = part_to_idx to si.part_count;
		     if part_array (part_from_idx).pv_name = pv.name
			& part_array (part_from_idx).name = vol_info.region (rx).part_name then do;
			part_hold_area = part_array (part_to_idx);
						/* save current info */
			part_array (part_to_idx) = part_array (part_from_idx);
						/* swap in new info */
			part_array (part_from_idx) = part_hold_area;
						/* replace with old */
			do part_to_idx = part_to_idx + 1 to si.part_count
			     while (part_array (part_to_idx).pv_name ^= pv.name);
						/* locate next partition */
			end;
			goto next_rx;
		     end;
		end;
next_rx:
	     end;
	end;
	else do;
	     sort_done = NO;
	     do part_to_idx = lbound (part_array, 1) to si.part_count
		while (part_array (part_to_idx).pv_name ^= pv.name);
						/* locate first partition */
	     end;
	     water_mark = 0;
	     do while (^sort_done);
		low_part_frec = vol_preamble.vol_size;	/* set to highest possible */
		do px = lbound (vol_preamble.parts, 1) to vol_preamble.nparts;
		     if vol_preamble.parts (px).frec < low_part_frec & vol_preamble.parts (px).frec > water_mark
		     then do;
			low_part_frec = vol_preamble.parts (px).frec;
			low_px = px;
		     end;
		end;
		if low_part_frec < vol_preamble.vol_size then do;
		     water_mark = low_part_frec;	/* bring up the low end */
		     do part_from_idx = part_to_idx to si.part_count;
			if part_array (part_from_idx).pv_name = pv.name
			     & part_array (part_from_idx).name = vol_preamble.parts (low_px).part then do;
			     part_hold_area = part_array (part_to_idx);
						/* save current info */
			     part_array (part_to_idx) = part_array (part_from_idx);
						/* swap in new info */
			     part_array (part_from_idx) = part_hold_area;
						/* replace with old */
			     do part_to_idx = part_to_idx + 1 to si.part_count
				while (part_array (part_to_idx).pv_name ^= pv.name);
						/* locate next partition */
			     end;
			     goto next_low_part;
			end;
		     end;
		end;
		else sort_done = YES;
next_low_part:
	     end;
	end;
	return;
     end SORT_PARTITION_LIST;
%page;
/**** Automatic */

dcl	code		fixed bin (35);
dcl	date_time_string	char (24);
dcl	density_idx	fixed bin;
dcl	doing_all_parts	bit (1);
dcl	i		fixed bin;
dcl	j		fixed bin;
dcl	my_name		char (8);
dcl	opr_input		char (128);		/* area to hold operator input */
dcl	partx		fixed bin;
dcl	part_entries	fixed bin;
dcl	restoring		bit (1);
dcl	rx		fixed bin;
dcl	setx		fixed bin (17);		/* current set_info index */
dcl	temp_partx	fixed bin;
dcl	volx		fixed bin;
dcl	vol_begin_tape	fixed bin;
dcl	vol_end_tape	fixed bin;

/**** Based variables */

dcl	1 cf_info		aligned based,
	  2 name		char (32),		/* name of file */
	  2 set		fixed bin,		/* SET file is in */
	  2 length	fixed bin (21),		/* char length of file */
	  2 ptr		ptr;			/* pointer to file */

dcl	1 part_area	(4, 64) aligned like part based (sri.part_area_ptr);

dcl	1 pv_area		(4, 63) aligned like pv based (sri.pv_area_ptr);

dcl	1 set_info	(4) aligned like si based (sri.set_infop);

dcl	1 tcb_area	(4, 0:16) aligned like tcb based (sri.tcb_area_ptr);

dcl	page		(0:1023) bit (36) aligned based;

/**** Constants & Builtins */

dcl	ALL_PARTS		char (4) int static options (constant) init ("-all");
dcl	ANY_DENSITY	bit (5) int static options (constant) init ("11111"b);
dcl	BREAKS		char (5) int static options (constant) init ("
	 ");						/* breaks: NL HT SP VT FF */
dcl	COMMENT_CHARS	char (3) int static options (constant) init ("""/&");
dcl	DEN556		bit (5) int static options (constant) init ("01000"b);
dcl	DEN800		bit (5) int static options (constant) init ("00100"b);
dcl	DEN1600		bit (5) int static options (constant) init ("00010"b);
dcl	DEN6250		bit (5) int static options (constant) init ("00001"b);
dcl	FIRST_TAPE_DEV_IDX	fixed bin int static options (constant) init (1);
dcl	IOTD		bit (2) unaligned int static options (constant) init ("00"b);
dcl	IOTP		bit (2) unaligned int static options (constant) init ("01"b);
dcl	MAX_BUFFERS	fixed bin int static options (constant) init (6);
dcl	MAX_PARTS_PER_VOL	fixed bin int static options (constant) init (7);
dcl	NL		char (1) int static options (constant) init ("
");
dcl	NO		bit (1) aligned int static options (constant) init ("0"b);
dcl	OFF		bit (1) aligned int static options (constant) init ("0"b);
dcl	ON		bit (1) aligned int static options (constant) init ("1"b);
dcl	VTOCES_PER_WORD	fixed bin (17) int static options (constant) init (32);
dcl	WORKSPACE_SIZE	fixed bin (18) int static options (constant) init (7168);
dcl	YES		bit (1) aligned int static options (constant) init ("1"b);
dcl	density_commands	(5) bit (6) int static options (constant) init ("64"b3, "61"b3, "60"b3, "65"b3, "41"b3);
dcl	density_table	(0:15) bit (5) int static options (constant)
						/* Used to set density characteristic. */
			init ("00010"b,		/* 1600 */
			"11100"b,			/* 200 , 556 , 800 */
			"00000"b,			/* Invalid */
			"00000"b,			/* Invalid */
			"11110"b,			/* 200, 556, 800, 1600 */
			"01110"b,			/* 556, 800, 1600 */
			"00000"b,			/* Invalid */
			"00111"b,			/* 800, 1600, 6250 */
			"00110"b,			/* 800, 1600 */
			"01100"b,			/* 556, 800 */
			"00000"b,			/* Invalid */
			"00011"b,			/* 1600, 6250 */
			"00000"b,			/* Invalid */
			"00000"b,			/* Invalid */
			"00000"b,			/* Invalid */
			"00000"b);		/* Invalid */
dcl	speed_table	(0:7) bit (3) int static options (constant)
						/* Used to set speed characteristics. */
			init ("000"b,		/* Invalid */
			"100"b,			/* 75 ips */
			"010"b,			/* 125 ips */
			"000"b,			/* Invalid */
			"001"b,			/* 200 ips */
			"000"b,			/* Invalid */
			"000"b,			/* Invalid */
			"000"b);			/* Invalid */

/**** Buffer State Constants */

dcl	FREE		fixed bin int static options (constant) init (0);
dcl	DISK_SUSPEND	fixed bin int static options (constant) init (1);
dcl	DISK_BUSY		fixed bin int static options (constant) init (3);
dcl	DISK_READY	fixed bin int static options (constant) init (4);

dcl	(addr, after, bin, bit, clock, divide, hbound, index, lbound, length, ltrim, max, mod, null, ptr, rel, rtrim,
	search, size, substr, unspec)
			builtin;

dcl	sub_request_abort_	condition;

/**** External variables & entries */

dcl	error_table_$bad_density
			fixed bin (35) ext static;
dcl	error_table_$device_not_usable
			fixed bin (35) ext static;
dcl	error_table_$incorrect_device_type
			fixed bin (35) ext static;
dcl	error_table_$no_device
			fixed bin (35) ext static;
dcl	error_table_$not_done
			fixed bin (35) ext static;
dcl	error_table_$unimplemented_version
			fixed bin (35) ext static;

dcl	bce_query		entry options (variable);
dcl	bootload_disk_io$queue_read
			entry (fixed bin, fixed bin (18), fixed bin, ptr, fixed bin, fixed bin (35));
dcl	bootload_disk_io$test_done
			entry (fixed bin, fixed bin (35));
dcl	bootload_fs_$get_ptr
			entry (char (*), ptr, fixed bin (21), fixed bin (35));
dcl	com_err_		entry () options (variable);
dcl	config_$find_periph entry (char (4) aligned, ptr);
dcl	date_time_	entry (fixed bin (71), char (*));
dcl	date_time_$format	entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var);
dcl	disk_name_pvtx	entry (char (8), fixed bin (17), fixed bin (35));
dcl	ioa_		entry () options (variable);
dcl	ioi_assignment$assign
			entry (fixed bin, char (*) aligned, fixed bin (71), bit (1) aligned, fixed bin (35));
dcl	ioi_assignment$unassign
			entry (fixed bin, fixed bin (35));
dcl	ioi_set$max_workspace
			entry (fixed bin, fixed bin (18), fixed bin (35));
dcl	ioi_set$status	entry (fixed bin, fixed bin (18), fixed bin (8), fixed bin (35));
dcl	ioi_set$workspace	entry (fixed bin, ptr, fixed bin (18), fixed bin (35));
dcl	read_disk		entry (fixed bin, fixed bin (18), ptr, fixed bin (35));
dcl	syserr		entry () options (variable);
dcl	syserr$error_code	entry () options (variable);
dcl	find_bit_$last_off	entry (bit (*)) returns (fixed bin (24));
%page;
%include bce_ioi_post_area;
%page;
%include bce_subsystem_info_;
%page;
%include bsr_structures;
%page;
%include bsr_tape_data;
%page;
%include bootload_post_area;
%page;
%include config_data_dcls;
%page;
%include config_prph_tap_card;
%page;
%include disk_pack;
%page;
%include fs_dev_types;
%page;
%include io_status_word;
%page;
%include ioi_stat;
%page;
%include iom_dcw;
%page;
%include iom_pcw;
%page;
%include pvt;
%page;
%include pvte;
%page;
%include syserr_constants;
%page;
%include tape_error_interp;
%page;
%include vol_map;
%page;
%include vtoc_map;
%page;
/*^ BEGIN MESSAGE DOCUMENTATION

   Message:
   bce_save_util_: Out of disk buffers for TAPE_SET.

   S:	$crash

   T:	$init

   M:	$err

   A:	$inform

   Message:
   restore: Attaching TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code in response to a request
   to assign TAPE_DEV.

   A:	$recover

   Message:
   restore: Could not read label of PV_NAME on DISK_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The volume label of the PV could not be read due to the error
   given in ERR_MESSAGE.

   A:	A operator query is done to find out if the read should be
   retried or the PV removed from the list.

   Message:
   restore(TAPE_SET): Device type mis-match. PV_NAME is on a DEV_TYPE,
	but was saved from a DEV_TYPE.

   S:	$info

   T:	$init

   M:	The program is unable to restore the contents of the PV because
   the disk device currently being used is different than the one in use
   when the PV was saved.  Only partitions can be restored to PVs mounted
   on different devices.

   A:	$recover

   Message:
   restore: Initiating CONTROL_FILE_NAME for set-TAPE_SET_IDX ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error was detected while initiating the restore control file.

   A:	$inform $recover

   Message:
   restore(TAPE_SET): MULTICS_VOL_ID PV_NAME on DISK_DEV
                       Last updated: DATE_TIME

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   restore(TAPE_SET): No partitions were saved for volume PV_NAME.
                      Removing from PV list.
   S:	$info

   T:	$init

   M:	A request has been made to restore one or more partitions on

   PV_NAME, but the save tape indicates that no partitions were saved.

   A:	Remove the partition reference from the control file.

   Message:
   restore(TAPE_SET): Only partitions were saved for volume PV_NAME.

   S:	$info

   T:	$init

   M:	A request to restore the contents of a PV has been made, but
   when the PV was saved only partitions were included.

   A:	Correct the control file(s) accordingly.

   Message:
   restore(TAPE_SET): Partition PARTITION_NAME is not defined on PV_NAME.

   S:	$info

   T:	$init

   M:	A request to restore specific partition has been made, but the
   partition does not exist of the PV.

   A:	Correct the control file(s) accordingly.

   Message:
   restore(TAPE_SET): Partition PARTITION_NAME on PV_NAME was not saved.

   S:	$info

   T:	$init

   M:	A request was made to restore a partition from a PV, but the
   partition was not saved as part of this tape set.

   A:	Correct the control file(s) accordingly.

   Message:
   restore(TAPE_SET): Please pre-mount tape# TAPE_NUMBER on TAPE_DEV.

   S:	$info

   T:	$init

   M:	The program is able to look ahead and find the tape that will be
   required next. This is an informative message that allows the restore
   to move at a faster pace.

   A:	Mount the specified tape on the specified device.

   Message:
   restore(TAPE_SET): Removing volume PV_NAME from PV list,
	because all partitions were removed.

   S:	$info

   T:	$init

   M:	It is nolonger necessary for the program to keep track of the
   PV, since all of the partition requests have been removed.

   A:	Correct the control files accordingly.

   Message:
   restore: Setting max workspace for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code in response to a request
   to set the max workspace size for TAPE_DEV.

   A:	$inform

   Message:
   restore: Setting up workspace for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code from the request to
   create a workspace for TAPE_DEV.

   A:	$inform

   Message:
   restore: TAPE_DEV ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error occured while scanning the tape subsystem survey data.

   A:	$recover

   Message:
   restore(TAPE_SET): Tape subsystem "SUB_SYS" is not defined in the config.

   S:	$info

   T:	$init

   M:	No "prph" entry could be found for the tape subsystem.

   A:	Correct config_deck or save/restore control file(s) to indicate
   proper tape subsystem.

   Message:
   restore(TAPE_SET): Unable to restore "PARTITION_NAME" partition.
	Internal partition list full.

   S:	$info

   T:	$init

   M:	More partitions have been requested than the program can handle.

   A:	Change control files to reduce the number defined, possibly by
   breaking them up into seperate tape sets.

   Message:
   restore(TAPE_SET): Unable to restore "PARTITION_NAME" partition.
	N partitions already defined

   S:	$info

   T:	$init

   M:	An attempt has been made to restore more than the N maximum
   partitions allowed.

   A:	Change control files(s) to reduce the number requested.

   Message:
   restore(TAPE_SET): Unable to restore only partitions.

   S:	$info

   T:	$init

   M:	A request to restore partition information on this PV was made,
   but the PV does not contain a vaild label to locate the partition
   information.  The PV is removed from the restore list.

   A:	$recover

   Message:
   restore(TAPE_SET): Volume PV_NAME not found in tape label.
		  Removing from PV list.

   S:	$info

   T:	$init

   M:	A request was made to restore a PV, but the PV was not saved as
   part of this tape set.

   A:	Correct the control file(s) accordingly.

   Message:
   restore(TAPE_SET): Volume PV_NAME will become NEW_PV_NAME, as requested.

   S:	$info

   T:	$init

   M:	The PV to be restored currently has a dirrerent label than that
   to be restored. This is only an informative message to make the user
   aware of the change.

   A:	$ignore

   Message:
   restore(TAPE_SET): Volume on DISK_DEV is not a MULTICS_VOL_ID.

   S:	$info

   T:	$init

   M:	Informative message to let the operator know that the volume
   does not currently contain a valid Multics label.

   A:	$ignore

   Message:
   restore: si ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error has been found with the internal "si" structure. $err

   A:	$inform

   Message:
   restore: sri ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error has been found with the internal "sri" structure. $err

   A:	$inform

   Message:
   save: Attaching TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code in response to a request
   to assign TAPE_DEV.

   A:	$recover

   Message:
   save: Could not read label of PV_NAME on DISK_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	The volume label of the PV could not be read due to the error
   given in ERR_MESSAGE.

   A:	A operator query is done to find out if the read should be
   retried or the PV removed from the list.

   Message:
   save: Initiating CONTROL_FILE_NAME for set-TAPE_SET_IDX ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error was detected while initiating the save control file.

   A:	$inform $recover

   Message:
   save(TAPE_SET): MULTICS_VOL_ID PV_NAME on DISK_DEV
                       Last updated: DATE_TIME

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Partition PARTITION_NAME is not defined on PV_NAME.

   S:	$info

   T:	$init

   M:	A request to save specific partition has been made, but the
   partition does not exist of the PV.

   A:	Correct the control file(s) accordingly.

   Message:
   save(TAPE_SET): Partition PARTITION_NAME of volume PV_NAME
	is not defined in the restart tape label.

   S:	$info

   T:	$init

   M:	There is an inconsistency between the restart tape and the save
   control file(s).

   A:	Either correct the control file(s) or start the save over from
   the beginning.

   Message:
   save(TAPE_SET): Removing volume PV_NAME from PV list,
	because there are no partitions to save.

   S:	$info

   T:	$init

   M:	Only partition requests were made for this volume and now for
   various reasons there are none left to save.

   A:	$recover

   Message:
   save(TAPE_SET): Removing volume PV_NAME from PV list,
	because all partitions were removed.

   S:	$info

   T:	$init

   M:	It is nolonger necessary for the program to keep track of the
   PV, since all of the partition requests have been removed.

   A:	Correct the control files accordingly.

   Message:
   save(TAPE_SET): Reverting "-all" partition request
	for volume PV_NAME, because there are no partitions to save.

   S:	$info

   T:	$init

   M:	This PV_NAME has no partitions defined.

   A:	$ignore

   Message:
   save: Setting max workspace for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code in response to a request
   to set the max workspace size for TAPE_DEV.

   A:	$inform

   Message:
   save: Setting up workspace for TAPE_DEV. ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	IOI has returned a non-zero error code from the request to
   create a workspace for TAPE_DEV.

   A:	$inform

   Message:
   save: TAPE_DEV ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error occured while scanning the tape subsystem survey data.

   A:	$recover

   Message:
   save(TAPE_SET): Tape subsystem "SUB_SYS" is not defined in the config.

   S:	$info

   T:	$init

   M:	No "prph" entry could be found for the tape subsystem.

   A:	Correct config_deck or save/restore control file(s) to indicate
   proper tape subsystem.

   Message:
   save(TAPE_SET): The "conf" partition of rpv is not being saved.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	Add the request to the save control file if desired.

   Message:
   save(TAPE_SET): The "file" partition of rpv is not being saved.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	Add the request to the save control file if desired.

   Message:
   save(TAPE_SET): The "log" partition of rpv is not being saved.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	Add the request to the save control file if desired.

   Message:
   save(TAPE_SET): Type of data being saved for volume PV_NAME
	does not match the type in the restart tape label.

   S:	$info

   T:	$init

   M:	There is an inconsistency between the restart tape and the save
   control file(s).

   A:	Either correct the control file(s) or start the save over from
   the beginning.

   Message:
   save(TAPE_SET): Unable to save "PARTITION_NAME" partition.
	Internal partition list full.

   S:	$info

   T:	$init

   M:	More partitions have been requested than the program can handle.

   A:	Change control files to reduce the number defined, possibly by
   breaking them up into seperate tape sets.

   Message:
   save(TAPE_SET): Unable to save "PARTITION_NAME" partition.
	N partitions already defined

   S:	$info

   T:	$init

   M:	An attempt has been made to save more than the N maximum
   partitions allowed.

   A:	Change control files(s) to reduce the number requested.

   Message:
   save(TAPE_SET): Volume PV_NAME not found in restart tape label.

   S:	$info

   T:	$init

   M:	There is an inconsistency between the restart tape and the save
   control file(s).

   A:	Either correct the control file(s) or start the save over from
   the beginning.

   Message:
   save(TAPE_SET): Volume PV_NAME requires salvaging.
	Setting -all to save all paging records on the volume.

   S:	$info

   T:	$init

   M:	Just an informative message.

   A:	$ignore

   Message:
   save(TAPE_SET): Volume PV_NAME's PVID does not match
	the one in the restart tape label.

   S:	$info

   T:	$init

   M:	There is an inconsistency between what is on the restart tape
   and what is currently defined on the PV's disk label.

   A:	Start the save over from the beginning.

   Message:
   save(TAPE_SET): Volume on DISK_DEV is not a MULTICS_VOL_ID.

   S:	$info

   T:	$init

   M:	The volume to be saved is not a valid Multics volume and
   therefore cannot be saved.

   A:	$recover

   Message:
   save(TAPE_SET): Volume was expected to be PV_NAME.

   S:	$info

   T:	$init

   M:	The PV name read from the disk label does not match the PV name
   that was defined in the save control file(s).

   A:	Correct the control file to show the proper PV name mounted on
   the device.

   Message:
   save: si ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error has been found with the internal "si" structure. $err

   A:	$inform

   Message:
   save: sri ERR_MESSAGE

   S:	$beep

   T:	$init

   M:	An error has been found with the internal "sri" structure. $err

   A:	$inform

   END MESSAGE DOCUMENTATION */

     end bce_save_util_;




		    tape_error_data.cds             11/11/89  1135.4rew 11/11/89  0826.7      116757



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Bull Inc., 1987                *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1986 *
   *                                                         *
   *********************************************************** */

/* format: style4,declareind10,dclind10,idind20,indattr,delnl,insnl,ifthenstmt */

tape_error_data:
     proc;

/* HISTORY COMMENTS:
  1) change(86-09-08,Farley), approve(86-07-18,MCR7439),
     audit(86-09-24,Fawcett), install(86-10-20,MR12.0-1189):
     Data Segment used for interpreting tape error status.  Code was copied
     from disk_error_data.cds.
  2) change(87-07-07,Farley), approve(87-07-17,MCR7733),
     audit(87-07-31,Fawcett), install(87-07-31,MR12.1-1051):
     Added "backspace" flag to 13/10 (ID Burst write errors) status.
                                                   END HISTORY COMMENTS */

dcl	1 cdsa		like cds_args aligned auto;
dcl	xnames		(1) char (32) aligned auto init ("*");

dcl	1 data		based (tempp (1)) aligned,
	  2 maj_array	(0:19) like tape_error_data,
	  2 sub_array	(nsub) like tape_error_interp;

dcl	nsub		fixed bin,		/* number of substatuses */
	charwds		fixed bin,		/* number of words of characters allocated */
	tempp		(2) ptr,			/* temp segs pointers */
	i		fixed bin,		/* iteration variable */
	rcode		fixed bin (35),		/* error code */
	nulldescriprel	bit (18) aligned,		/* rel ptr to null char string */
	teirel		bit (18) aligned,		/* rel pointer to interpretation data */
	tsdrel		bit (18) aligned;		/* rel pointer to charactr string */

dcl	get_temp_segments_	entry (char (*), (*) ptr, fixed bin (35)),
	release_temp_segments_
			entry (char (*), (*) ptr, fixed bin (35)),
	create_data_segment_
			entry (ptr, fixed bin (35)),
	com_err_		entry options (variable);

dcl	copy_chars	(charwds) fixed bin (35) based;
						/* structure for copying characters */

dcl	(
	NRETRIES		init (8),
	NONE		init (0),
	ONCE		init (1)
	)		fixed bin (5) static options (constant);

dcl	(addr, addrel, bin, bit, divide, hbound, index, length, null, rel, size, translate, string, unspec)
			builtin;

dcl	cleanup		condition;
%page;
%include tape_error_interp;
%page;
%include cds_args;
%page;
	tempp (*) = null ();

	on cleanup call clean_up;

	call get_temp_segments_ ("tape_error_data", tempp, rcode);
	if rcode ^= 0 then do;
	     call com_err_ (rcode, "tape_error_data", "get_temp_segments_");
	     goto nl_exit;
	end;

	tedp = tempp (1);
	tsdp = tempp (2);

	nsub = 1;
	taperp = addr (data.sub_array (1));
	charwds = 0;

	nulldescriprel = allocate_tsd ("");
	teirel = compute_rel (tedp, taperp);
	tsdrel = allocate_tsd ("error");
	do i = 0 to hbound (data.maj_array, 1);
	     data.maj_array (i).interp = teirel;
	     data.maj_array (i).namep = tsdrel;
	end;
	call set_substat ("XXXXXX", NONE, "", "");
%page;
	call set_majstat (0, "Device Ready");
	call set_substat ("000000", NONE, "Ready", "");
	call set_substat ("XX0XX1", NONE, "Write protected", "");
	call set_substat ("000X1X", NONE, "Positioned at BOT", "");
	call set_substat ("XXX1XX", NONE, "Nine track handler", "");
	call set_substat ("010X0X", NONE, "Two bit fill", "");
	call set_substat ("100X0X", NONE, "Four bit fill", "");
	call set_substat ("110X0X", NONE, "Six bit fill", "");
	call set_substat ("001100", NONE, "ASCII alert", "");

	call set_majstat (1, "Device Busy");
	call set_substat ("000001", NONE, "Tape rewinding", "special");
	call set_substat ("000010", NRETRIES, "Alternate channel in control", "");
	call set_substat ("000100", NONE, "Device loading", "special");
	call set_substat ("100000", NONE, "Device reserved", "bad_dev");

	call set_majstat (2, "Device Attention");
	call set_substat ("00XX01", NONE, "Write protected", "");
	call set_substat ("000010", NONE, "No such tape handler", "bad_dev");
	call set_substat ("0XX10X", NONE, "Handler in standby", "bad_dev");
	call set_substat ("0X1X0X", NONE, "Handler check", "bad_dev,detail");
	call set_substat ("01XX00", NONE, "Blank tape on write", "bad_dev,detail");

	call set_majstat (3, "Device Data Alert");
	call set_substat ("000001", NRETRIES, "Transfer timing alert", "backspace");
	call set_substat ("000010", NONE, "Blank tape on read", "eot");
	call set_substat ("XXXX11", NONE, "Bit detected during erase", "bad_dev,detail");
	call set_substat ("XXX1XX", NRETRIES, "Transmission parity alert", "backspace");
	call set_substat ("XX1XXX", NRETRIES, "Lateral parity alert", "backspace");
	call set_substat ("X1XXXX", NRETRIES, "Longitudinal parity alert", "backspace");
	call set_substat ("1XXXXX", NONE, "End of tape mark detected", "eot");

	call set_majstat (4, "End of File");
	call set_substat ("001111", NONE, "7 track EOF", "eof");
	call set_substat ("010011", NONE, "9 track EOF", "eof");
	call set_substat ("111111", NONE, "Data alert condition", "");

	call set_majstat (5, "Command Reject");
	call set_substat ("000000", NONE, "Invalid density", "bad_density");
	call set_substat ("000XX1", NONE, "Invalid operation code", "");
	call set_substat ("000X1X", NONE, "Invalid device code", "");
	call set_substat ("0001XX", NONE, "Invalid IDCW parity", "");
	call set_substat ("001000", NONE, "Positioned at BOT", "");
	call set_substat ("010000", NONE, "Forward read after write", "");
	call set_substat ("100000", NONE, "Nine track error", "");

	call set_majstat (10, "Controller Attention");
	call set_substat ("000001", NONE, "Configuration switch error", "bad_path");
	call set_substat ("000010", NONE, "Multiple devices", "");
	call set_substat ("000011", NONE, "Illegal device number", "");
	call set_substat ("001000", NONE, "Incompatible mode", "bad_density");
	call set_substat ("001100", NONE, "TCA malfunction (0)", "bad_path,detail");
	call set_substat ("001101", NONE, "TCA malfunction (1)", "bad_path,detail");
	call set_substat ("010000", NONE, "MTH malfunction", "bad_dev,detail");
	call set_substat ("010001", NONE, "Multiple BOT", "bad_dev");

	call set_majstat (11, "Controller Data Alert");
	call set_substat ("000001", NRETRIES, "Transmission parity alert", "bad_path,backspace");
	call set_substat ("000010", NONE, "Inconsistent command", "");
	call set_substat ("000011", NRETRIES, "Sum check error", "bad_path,detail");
	call set_substat ("000100", NRETRIES, "Byte locked out", "bad_path");
	call set_substat ("001000", NRETRIES, "ID Burst write error", "backspace,detail");
	call set_substat ("001001", NRETRIES, "Preamble error", "backspace");
	call set_substat ("001010", NRETRIES, "T&D error", "");
	call set_substat ("010000", NRETRIES, "Multi-track error", "backspace");
	call set_substat ("010001", NRETRIES, "Skew error", "backspace");
	call set_substat ("010010", NRETRIES, "Postamble error", "backspace");
	call set_substat ("010011", NRETRIES, "NRZI CCC error", "backspace");
	call set_substat ("010100", NRETRIES, "Code alert", "backspace");
	call set_substat ("100000", NRETRIES, "Marginal condition", "backspace");

	call set_majstat (13, "Controller Command Reject");
	call set_substat ("000000", NONE, "Indeterminate Density", "bad_density");
	call set_substat ("000001", NONE, "Illegal procedure", "");
	call set_substat ("000010", NONE, "Illegal logical channel", "");
	call set_substat ("000011", NONE, "Illegal suspended logical chnl", "special");
	call set_substat ("000100", NONE, "Continue bit not set", "");

	call set_majstat (POWER_OFF, "power off");
	call set_substat ("XXXXXX", NRETRIES, "", "bad_path");

	call set_majstat (CHAN_STAT, "chan stat");
	call set_substat ("001000", ONCE, "connect while busy", "");
	call set_substat ("010000", ONCE, "illeg chan instruct", "");
	call set_substat ("011000", ONCE, "incorrect DCW", "");
	call set_substat ("100000", ONCE, "incomplete instruct seq", "bad_path");
	call set_substat ("110000", NRETRIES, "PSI parity err", "bad_path");
	call set_substat ("111000", NRETRIES, "parity err, I/O bus to chan", "bad_path");
	call set_substat ("XXXXXX", NRETRIES, "", "bad_path");

	call set_majstat (CENTRAL_STAT, "central stat");
	call set_substat ("001000", ONCE, "LPW tally runout", "bad_path");
	call set_substat ("010000", ONCE, "two TDCW's in a row", "bad_path");
	call set_substat ("011000", ONCE, "boundary error", "bad_path");
	call set_substat ("100000", ONCE, "A.E. change in restricted mode", "bad_path");
	call set_substat ("101000", ONCE, "IDCW in restricted mode", "bad_path");
	call set_substat ("110000", ONCE, "char pos/size discrepancy", "bad_path");
	call set_substat ("111000", ONCE, "parity err, data from chan", "bad_path");
	call set_substat ("XXXXXX", NRETRIES, "", "bad_path");

	call set_majstat (SYS_FAULT, "system fault");
	call set_substat ("XXXXXX", ONCE, "", "bad_path");
%page;
	taperp -> copy_chars = tempp (2) -> copy_chars;	/* copy the characters now. */

	nsub = nsub - 1;				/* back down one */

	do i = 0 to hbound (data.maj_array, 1);
	     call relocate_rel (data.maj_array (i).namep);
	end;

	do i = 1 to nsub;
	     call relocate_rel (data.sub_array (i).namep);
	end;

	cdsa.sections (1).p = tempp (1);
	cdsa.sections (1).len = size (data) + charwds;
	cdsa.sections (1).struct_name = "data";

	cdsa.seg_name = "tape_error_data";
	cdsa.num_exclude_names = 1;
	cdsa.exclude_array_ptr = addr (xnames);

	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;

	call create_data_segment_ (addr (cdsa), rcode);
	if rcode ^= 0 then call com_err_ (rcode, "tape_error_data", "create_data_segment_");

nl_exit:
	call clean_up;
	return;
%page;
clean_up:
     proc;
	if tempp (1) ^= null () then do;
	     call release_temp_segments_ ("tape_error_data", tempp, rcode);
	     if rcode ^= 0 then call com_err_ (rcode, "tape_error_data", "release_temp_segments_");
	end;
	return;
     end clean_up;
%page;
set_majstat:
     proc (mjs, descrip);				/* proc to fill in major status array */

dcl	mjs		fixed bin,		/* major status */
	descrip		char (*) aligned;		/* major status description */

	if mjs > hbound (data.maj_array, 1) then do;
	     call com_err_ (0, "tape_error_data", "The bounds of the major status array have been exceeded.");
	     call com_err_ (0, "tape_error_data", "Current value = ^d, must be at least ^d.",
		hbound (data.maj_array, 1), mjs);
	     go to nl_exit;
	end;
	data.maj_array (mjs).interp = compute_rel (tedp, taperp);
	data.maj_array (mjs).namep = allocate_tsd (descrip);

	return;
     end set_majstat;
%skip (4);
set_substat:
     proc (stat, retry, descrip, errs);			/* proc to allocate tape_error_interp structure */

dcl	stat		char (6) aligned,
	retry		fixed bin (5),
	descrip		char (*) aligned,
	errs		char (*) aligned;

	unspec (tape_error_interp) = "0"b;

	tape_error_interp.bitson = bit (translate (stat, "0", "X"), 6);
	tape_error_interp.bitmask = bit (translate (stat, "10", "0X"), 6);
	tape_error_interp.max_retries = retry;
	if descrip ^= ""
	then tape_error_interp.namep = allocate_tsd (descrip);
	else tape_error_interp.namep = nulldescriprel;

	call seterr (errs, "backspace", tape_error_interp.backspace);
	call seterr (errs, "bad_density", tape_error_interp.bad_density);
	call seterr (errs, "bad_dev", tape_error_interp.bad_dev);
	call seterr (errs, "bad_path", tape_error_interp.bad_path);
	call seterr (errs, "detail", tape_error_interp.get_detail);
	call seterr (errs, "eof", tape_error_interp.end_of_file);
	call seterr (errs, "eot", tape_error_interp.end_of_tape);
	call seterr (errs, "special", tape_error_interp.expect_special);

	nsub = nsub + 1;				/* Count one more. */
	taperp = addr (data.sub_array (nsub));

	return;
     end set_substat;
%page;
seterr:
     proc (errstring, errname, errbit);			/* procedure to set error bit */

dcl	errstring		char (*) aligned,
	errname		char (*) aligned,
	errbit		bit (1) unal;

	if index (errstring, errname) > 0 then errbit = "1"b;

	return;
     end seterr;
%page;
allocate_tsd:
     proc (descrip) returns (bit (18) aligned);		/* procedure to allocate character string */

dcl	descrip		char (*) aligned;

dcl	old_tsdp		ptr,
	chlth		fixed bin;

	tape_status_descrip.lth = length (descrip);
	tape_status_descrip.chr = descrip;

	chlth = divide (length (descrip), 4, 17, 0) + 1;
	charwds = charwds + chlth;
	old_tsdp = tsdp;
	tsdp = addrel (tsdp, chlth);

	return (compute_rel (tempp (2), old_tsdp));
     end allocate_tsd;
%skip (4);
compute_rel:
     proc (basep, strucp) returns (bit (18) aligned);	/* procedure to compute relative offset */

dcl	basep		ptr,			/* pointer to database */
	strucp		ptr;			/* pointer to structure */

	return (bit (bin (bin (rel (strucp), 18) - bin (rel (basep), 18), 18), 18));
     end compute_rel;
%skip (4);
relocate_rel:
     proc (relp);					/* proc to relocate name pointers */

dcl	relp		bit (18) unal;		/* name relative pointer */

	relp = bit (bin (bin (relp, 18) + bin (rel (taperp), 18), 18), 18);

	return;
     end relocate_rel;
     end tape_error_data;






		    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
