



		    read_tape_and_query.pl1         07/28/87  0923.2rew 07/28/87  0918.9      198423



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


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




/****^  HISTORY COMMENTS:
  1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692),
     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
     convert read_tape_and_query (rtq) nonstandard subsystem to a standard
     ssu_ subsystem:  initialize intermediate variables.  Get optional
     control arguments and their required partners (e.g. -comment STR).
     Establish cleanup and program_interrupt conditions.  Create an
     invocation of rtq subsystem.  Add the 2nd ssu_ request table to the
     list of tables.  Add the 2nd ssu_ info directory to the list of
     directoies.  Get the default request processor options for rtq.
     Set prompt string for rtq.  Set up fields of the "rtq_structure_
     info" record structure.  Call "rtq_$set_up" external procedure.
     Set up for "-quit".  Set up for "-request" and handle its possible
     errors.  Invoke "ssu_$listen" and handle its possible error.
     Invoke "terminate_null_ref_name" to terminate file if already
     initiated.  Invoke "read_tape_and_query_janitor" to detach and
     close tape and file.  Finally, invoke "ssu_$destroy_invocation"
     to destroy invocation if already created.
                                                   END HISTORY COMMENTS */


/* read_tape_and_query - written Sept 1977 by James A. Bush
   Modified 9/10/79 by J. A. Bush for installation in MR8.0
   Modified 3/11/80 by P. B. Kelley to:
   1) Fix bug preventing use of "-track".
   2) Remove automatic large buffer if user has access to rcp_sys_.
   3) Implement the "-block" control argument.
   4) Fixes bug which caused rtq to return if a tape mark was encountered
   while attempting to determine the correct density.
   Modified 7/30/80 by J. A. Bush to:
   1) Fix several tape positioning bugs.
   2) Implement the "-density" and "-no_prompt" control arguments.
   3) Add the "list_tape_contents" and "bof" requests.
   4) Add tape label/trailer record recognition and display capabilities.
   5) Add the "-count" argument to the "read_record" and "read_file" requests.
   Modified 01/02/81 by J. A. Bush to:
   1) Recognize and diplay version 2 standard Multics tape labels.
   2) Fix bug with "-skip" read_file  request argument.
   3) Implement the "-multics", "-nnl" and "-extend" read_file request arguments.
   4) Implement the "-ring" control argument.
   Modified 4/82 by J. A. Bush to fix some bugs
   Modified 11/82 by J. A. Bush to fix some more bugs
*/

read_tape_and_query: rtq: proc;

/* formated by default */

	dcl     abbrev_specified_flg	 bit (1);
	dcl     arg_count		 fixed bin;
	dcl     arg_length		 fixed bin (21);
	dcl     arg_ptr		 ptr;
	dcl     arg_dex		 fixed bin;
	dcl     array_index		 fixed bin;
	dcl     bit_count		 fixed bin (24);
	dcl     (blocksize, code)	 fixed bin (35);
	dcl     buf_size		 fixed bin (21);	/* default buffer size */
	dcl     ddec		 fixed bin (35);	/* density decimal */
	dcl     dir_name		 char (168);
	dcl     entry_name		 char (32);
	dcl     match		 bit (1) aligned;
	dcl     no_prompt_specified_flg bit (1);
	dcl     profile_ptr		 ptr;
	dcl     prompt_length	 fixed bin (21);
	dcl     prompt_ptr		 ptr;
	dcl     quit_specified_flg	 bit (1);
	dcl     request_line_length	 fixed bin (21);
	dcl     request_line_ptr	 ptr;
	dcl     request_loop_specified_flg bit (1);
	dcl     request_specified_flg	 bit (1);
	dcl     rtq_info_ptr           ptr;
	dcl     sci_ptr		 ptr;
	dcl     tape_name		 char (8);
	dcl     tape_atd		 char (200);
	dcl     tdec		 fixed bin (35);	/* track decimal */
	dcl     var_prompt_string	 char (64) varying;
	dcl     wd_buf_size		 fixed bin;	/* default buffer size in words */

/* based */
	dcl     arg		 char (arg_length) based (arg_ptr);
	dcl     prompt_string	 char (prompt_length) based (prompt_ptr);
	dcl     request_line	 char (request_line_length) based (request_line_ptr);
	dcl     1 rtq_info		 aligned like rtq_structure_info based (rtq_info_ptr);		      

/* builtin */
	dcl     (addr, char, divide, fixed, hbound, ltrim, mod, null, rtrim, substr) builtin;

/* condition */
	dcl     (cleanup, program_interrupt) condition;

/* constants */
	dcl     DEFAULT_BUFFER_SIZE	 fixed bin static options (constant) init (2800);
	dcl     NEXT_POS_IN_THE_LIST_OF_TABLES fixed bin static options (constant) init (2);
	dcl     NINE_TRACK		 fixed bin static options (constant) init (9);
	dcl     NUMBER_OF_CHARACTER_PER_WORD fixed bin static options (constant) init (4);
	dcl     SEVEN_TRACK		 fixed bin static options (constant) init (7);
	dcl     density		 (5) char (5) static options (constant) init
				 ("d800", "d1600", "d6250", "d556", "d200");
	dcl     info_dir		 char (168) int static options (constant) init (">doc>subsystem>read_tape_and_query");
	dcl     rtq_version_1	 char (8) static options (constant) init ("rtq.1");
	dcl     pname		 char (19) int static options (constant) init
				 ("read_tape_and_query");
	dcl     whoami		 char (32) static options (constant) init ("rtq");

/* entries */
	dcl     com_err_		 entry options (variable);
	dcl     cu_$arg_count	 entry (fixed bin, fixed bin (35));
	dcl     cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     rtq_$set_up		 entry (ptr, ptr, fixed bin (35));
	dcl     requote_string_	 entry (char (*)) returns (char (*));
	dcl     ssu_$add_info_dir	 entry (ptr, char (*), fixed bin, fixed bin (35));
	dcl     ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
	dcl     ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
	dcl     ssu_$destroy_invocation entry (ptr);
	dcl     ssu_$execute_line	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     ssu_$get_default_rp_options entry (ptr, char (8), ptr, fixed bin (35));
	dcl     ssu_$listen		 entry (ptr, ptr, fixed bin (35));
	dcl     ssu_$set_prompt_mode	 entry (ptr, bit (*));
	dcl     ssu_$set_prompt	 entry (ptr, char (64) varying);
	dcl     ssu_$set_request_processor_options entry (ptr, ptr, fixed bin (35));
	dcl     terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));

/* external */
	dcl     error_table_$bad_arg	 fixed bin (35) ext static;
	dcl     error_table_$badcall	 fixed bin (35) ext static;
	dcl     error_table_$inconsistent fixed bin (35) ext static;
	dcl     rtq_request_table_$rtq_request_table_ fixed bin (35) external static;
	dcl     ssu_et_$subsystem_aborted fixed bin (35) external static;
	dcl     ssu_et_$null_request_line fixed bin (35) ext static;
	dcl     ssu_et_$program_interrupt fixed bin (35) ext static;
	dcl     ssu_et_$request_line_aborted fixed bin (35) ext static;
	dcl     ssu_info_directories_$standard_requests char (168) external;
	dcl     ssu_request_tables_$standard_requests fixed bin (35) external;


%page;
/* initialized intermediate variables */
	call init_intermediate_variables;

/* get users 's optional control arguments */
	call get_users_optional_control_args;

	if code ^= 0 then do;
	     call terminate_null_ref_name;
	     return;
	     end;

/* establish cleanup condition */
	on cleanup goto FINISH_SUBSYSTEM;

/* establish program_interrupt condition */
	on program_interrupt goto INVOKE_LISTEN;

/* create a invocation of a subsystem */
	call ssu_$create_invocation (whoami, rtq_version_1, addr (rtq_structure_info),
	     addr (rtq_request_table_$rtq_request_table_),
	     info_dir, sci_ptr, code);
	if code ^= 0 then do;
		call com_err_ (code, pname, "Creating subsystem invocation.");
		goto DESTROY_INVOCATION;
	     end;

/* add ssu_request_table_ as the 2nd request table in the list of tables */
	call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests),
	     NEXT_POS_IN_THE_LIST_OF_TABLES, code);
	if code ^= 0 then do;
		call com_err_ (code, pname, "Adding standard ssu_ request table as the 2nd table.");
		goto DESTROY_INVOCATION;
	     end;

/* add standard ssu_info_directories at the 2nd position in the info directories*/
	call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests,
	     NEXT_POS_IN_THE_LIST_OF_TABLES, code);
	if code ^= 0 then do;
		call com_err_ (code, pname, "Adding standard ssu_ request info segs.");
		goto DESTROY_INVOCATION;
	     end;

/* get the default request processor options for the rtq subsystem */
	if abbrev_specified_flg then do;
		call ssu_$get_default_rp_options (sci_ptr, RP_OPTIONS_VERSION_1, addr (local_rpo), (0));
		local_rpo.abbrev_info.expand_request_lines = "1"b;
		local_rpo.abbrev_info.default_profile_ptr = profile_ptr;
		local_rpo.abbrev_info.profile_ptr = profile_ptr;

		call ssu_$set_request_processor_options (sci_ptr, addr (local_rpo), (0));
	     end;

/* set prompt string for the rtq subsystem */
	if no_prompt_specified_flg | prompt_length = -1 then
	     call ssu_$set_prompt_mode (sci_ptr, DONT_PROMPT);
	else if prompt_length > 0 then do;		/* set user_specified prompt */
		var_prompt_string = prompt_string;
		call ssu_$set_prompt (sci_ptr, var_prompt_string); /* make it varying for ssu_ */
	     end;
	else call ssu_$set_prompt_mode (sci_ptr, PROMPT); /* by default */

/* make things ready before performing user's requests */
	rtq_info_ptr = addr (rtq_structure_info);

	call fill_in_fields_of_rtq_stru_info;

	call rtq_$set_up (sci_ptr, rtq_info_ptr, code);
	if code ^= 0 then
		goto DESTROY_INVOCATION;		/* don't want additional message. */

	if quit_specified_flg then
	     goto FINISH_SUBSYSTEM;

	if request_specified_flg then do;
		call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_length, code);
		if code ^= 0 then do;
			if code = ssu_et_$null_request_line | code = ssu_et_$program_interrupt |
			     code = ssu_et_$request_line_aborted then goto INVOKE_LISTEN;

			else if code = ssu_et_$subsystem_aborted then
			     goto FINISH_SUBSYSTEM;

			else do;
				call com_err_ (code, whoami);
				goto FINISH_SUBSYSTEM;
			     end;
		     end;
	     end;
						/* invokes listen */
INVOKE_LISTEN:

	call ssu_$listen (sci_ptr, null (), code);
	if code ^= ssu_et_$subsystem_aborted then
	     call com_err_ (code, pname, "Calling the listener.");

/* finishes subsystem */
FINISH_SUBSYSTEM:
	call read_tape_and_query_janitor (sci_ptr, rtq_info_ptr);

DESTROY_INVOCATION:

	call terminate_null_ref_name;

	call ssu_$destroy_invocation (sci_ptr);

	return;

/**************************************************************************/
%page;
fill_in_fields_of_rtq_stru_info: proc ();

/* fill in "rtq_structure_info" structure's field values after processing */
/* control argument and got the structure's address.                      */

	rtq_structure_info.atd_sw, rtq_structure_info.buf_ful, rtq_structure_info.eof, rtq_structure_info.eov = "0"b;
	rtq_info.eof_request_flg = "0"b;
	rtq_structure_info.extend_sw, rtq_structure_info.f_attached, rtq_structure_info.fw_file = "0"b;
	rtq_structure_info.last_job_deck_flg, rtq_structure_info.one_eof, rtq_structure_info.return_subsys_loop_flg = "0"b;
	rtq_info.records_in_file_flg = "0"b;
	rtq_structure_info.set_bin, rtq_structure_info.set_nine, rtq_structure_info.tmr, rtq_structure_info.two_eofs = "0"b;
	rtq_structure_info.bits, rtq_structure_info.block_size, rtq_structure_info.clen, rtq_structure_info.cvbl = 0;
	rtq_structure_info.l_type, rtq_structure_info.rec_len = 0;
	rtq_structure_info.c_file, rtq_structure_info.c_mode, rtq_structure_info.c_rec = 1;
	rtq_structure_info.cbufp, rtq_structure_info.cdkp, rtq_structure_info.cdptr, rtq_structure_info.cfptr = null;
	rtq_structure_info.cvp, rtq_structure_info.cvbp, rtq_structure_info.fiocb_ptr, rtq_structure_info.lblp = null;
	rtq_structure_info.rptr, rtq_structure_info.rtq_area_ptr, rtq_structure_info.tiocb_ptr, rtq_structure_info.tptr = null;
	rtq_structure_info.c_den, rtq_structure_info.filename, rtq_structure_info.filepath = "";
	rtq_structure_info.buf_size = buf_size;
	rtq_structure_info.ddec = ddec;
	rtq_structure_info.density = density;
	rtq_structure_info.tape_atd = tape_atd;
	rtq_structure_info.tape_name = tape_name;
	rtq_structure_info.tdec = tdec;
	rtq_structure_info.Version = rtq_version_1;
	rtq_structure_info.wd_buf_size = wd_buf_size;

     end fill_in_fields_of_rtq_stru_info;

/**************************************************************************/
%page;

get_nxt_arg: proc returns (bit (1) aligned);
						/* get_nxt_arg - function to get next command line argument */

	dcl     old_arg		 char (32) init ("");

/* begin coding */
	old_arg = arg;				/* copy arg for error messages */
	arg_dex = arg_dex + 1;
	call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code); /* get comment arg */
	if code ^= 0 then do;			/* error */
		call com_err_ (code, pname, "obtaining ""^a"" specification.", old_arg);
		return ("0"b);
	     end;
	return ("1"b);				/* return ok */

     end get_nxt_arg;

/***********************************************************************/
%page;
get_users_optional_control_args: proc;

/* the 1st input argument typed in must be reel identifier */
	call cu_$arg_count (arg_count, code);
	call cu_$arg_ptr (1, arg_ptr, arg_length, code);
	if code ^= 0 then do;
		call com_err_ (code, pname, "Getting reel_id.");
		call ioa_ ("Usage:  read_tape_and_query (rtq) reel_id {-control_args}");
		call ioa_ ("^/CONTROL ARGUMENTS ^/-abbrev, -ab ^/-block N, -bk N ^/-comment STR ^/-density N, -den N" ||
		     "^/-no_abbrev, -nab ^/-no_prompt ^/-no_request_loop, -nrql ^/-profile PATH, -pf PATH ^/-prompt STR" ||
		     "^/-quit ^/-request STR, -rq STR ^/-request_loop, -rql  ^/-ring ^/-track N, -tk N");
		return;
	     end;

/* save reel number and establish tape attach description */
	tape_name = arg;
	tape_atd = "tape_nstd_ " || arg;

/* process all optional input control arguments if they are specified */
	do arg_dex = 2 by 1 to arg_count while (code = 0);
	     call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code); /* look for more arguments */
	     if code ^= 0 then ;			/* if args exhausted, look no further */

	     else if arg = "-comment" | arg = "-com" then do; /* User wants to send OPR message */
		     if ^get_nxt_arg () then return;	/* if some problem with required arg, quit */
		     tape_atd = rtrim (tape_atd) || " -comment " ||
			requote_string_ ((arg));	/* put in quoted comment */
		end;

	     else if arg = "-track" | arg = "-tk" then do;/* next arg must be 7 or 9 */
		     if ^get_nxt_arg () then return;	/* if some problem with required arg, quit */
		     tdec = cv_dec_check_ (arg, code);	/* convert to dec. for check */
		     if code ^= 0 then go to bad_arg;	/* must be numeric */
		     if tdec ^= SEVEN_TRACK & tdec ^= NINE_TRACK then go to bad_arg; /* and only 7 or 9 */
		     tape_atd = rtrim (tape_atd) || " -track " ||
			ltrim (char (tdec));	/* insert leading blank */
		end;

	     else if arg = "-block" | arg = "-bk" then do;/* next arg must be blocksize */
		     if ^get_nxt_arg () then return;	/* if some problem with required arg, quit */
		     blocksize = cv_dec_check_ (arg, code);
		     if code ^= 0 then go to bad_arg;
		     tape_atd = rtrim (tape_atd) || " -block " || ltrim (char (blocksize));
		     buf_size = blocksize + mod (blocksize, NUMBER_OF_CHARACTER_PER_WORD); /* set buffer size in chars, mod 4 */
		     wd_buf_size = divide (buf_size, NUMBER_OF_CHARACTER_PER_WORD, 17, 0); /* and in words */
		end;

	     else if arg = "-density" | arg = "-den" then do; /* next arg must be density value */
		     if ^get_nxt_arg () then return;	/* if some problem with required arg, quit */
		     ddec = cv_dec_check_ (arg, code);
		     if code ^= 0 then go to bad_arg;

		     match = "0"b;
		     do array_index = 1 to hbound (density, 1) while (^match);
			if ddec = fixed (substr (density (array_index), 2, 4)) then do;
				match = "1"b;
				tape_atd = rtrim (tape_atd) || " -density " || ltrim (char (ddec));
			     end;
		     end;
		     if ^match then
			go to bad_arg;
		end;

	     else if arg = "-prompt" then do;
		     arg_dex = arg_dex + 1;

		     call cu_$arg_ptr (arg_dex, prompt_ptr, prompt_length, code);
		     if code ^= 0 then do;
			     call com_err_ (code, pname, "Trying to get the prompt string.");
			     return;
			end;
		     if prompt_length = 0 then prompt_length = -1;
		end;

	     else if arg = "-no_prompt" then
		no_prompt_specified_flg = "1"b;

	     else if arg = "-ring" | arg = "-rg" then /* user wants to attach tape with write ring */
		tape_atd = rtrim (tape_atd) || " -write";

	     else if arg = "-request_loop" | arg = "-rql" then do;
		     if quit_specified_flg then do;
INCONSISTENT:
			     call com_err_ (error_table_$inconsistent, pname, "-request_loop and -quit");

			     return;
			end;
		     else request_loop_specified_flg = "1"b;
		end;

	     else if arg = "-no_request_loop" | arg = "-nrql" then
		request_loop_specified_flg = "0"b;

	     else if arg = "-abbrev" | arg = "-ab" then
		abbrev_specified_flg = "1"b;

	     else if arg = "-no_abbrev" | arg = "-nab" then
		abbrev_specified_flg = "0"b;

	     else if arg = "-profile" | arg = "-pf" then do;
		     abbrev_specified_flg = "1"b;
		     arg_dex = arg_dex + 1;

		     call cu_$arg_ptr (arg_dex, arg_ptr, arg_length, code);
		     if code ^= 0 then goto bad_arg;
		     call expand_pathname_$add_suffix (arg, "profile", dir_name, entry_name, code);
		     if code ^= 0 then goto bad_arg;

		     call initiate_file_ (dir_name, entry_name, R_ACCESS, profile_ptr, bit_count, code);
		     if profile_ptr = null then do;
			     call com_err_ (code, pname, "Initiating the profile:  ", pathname_ (dir_name, entry_name));
			     return;
			end;
		end;

	     else if arg = "-quit" then do;
		     if request_loop_specified_flg then goto INCONSISTENT;
		     else quit_specified_flg = "1"b;
		end;

	     else if arg = "-request" | arg = "-rq" then do;
		     if request_specified_flg then do;
			     call com_err_ (error_table_$badcall, pname, "Only one request line allowed.");
			     return;
			end;
		     else do;
			     request_specified_flg = "1"b;
			     arg_dex = arg_dex + 1;

			     call cu_$arg_ptr (arg_dex, request_line_ptr, request_line_length, code);
			     if code ^= 0 then do;
				     call com_err_ (code, pname, "Trying to get the request line.");
				     return;
				end;
			end;
		end;

	     else do;
		     if substr (arg, 1, 1) = "-" then do;
bad_arg:
			     call com_err_ (error_table_$bad_arg, pname, "argument number ^d: ""^a""", arg_dex, arg);
			     return;
			end;
		end;
	end;					/* do argdex = 2 by 1 while code = 0 */

     end get_users_optional_control_args;

/***********************************************************************/
%page;
init_intermediate_variables: proc ();

/* begin coding */
	abbrev_specified_flg, no_prompt_specified_flg, quit_specified_flg, request_loop_specified_flg, request_specified_flg = "0"b;
	arg_length, arg_dex, blocksize, code, ddec, prompt_length, request_line_length, tdec = 0;
	arg_ptr, profile_ptr, prompt_ptr, request_line_ptr, rtq_info_ptr, sci_ptr = null;
	dir_name, entry_name, tape_name, tape_atd, var_prompt_string = "";
	buf_size = DEFAULT_BUFFER_SIZE * NUMBER_OF_CHARACTER_PER_WORD;
	wd_buf_size = DEFAULT_BUFFER_SIZE;

     end init_intermediate_variables;

/***********************************************************************/
%page;
read_tape_and_query_janitor: proc (sci_ptr, rtq_info_ptr);
						/* detach_tape_file - internal procedure to detach and close tape and file */

	dcl     release_area_ entry (ptr);
	dcl     (rtq_info_ptr, sci_ptr) ptr;

/* close and detach  tape switch which was attached and opened early */
	if rtq_info.tiocb_ptr ^= null then do;
		call iox_$close (rtq_info.tiocb_ptr, (0));
		call iox_$detach_iocb (rtq_info.tiocb_ptr, (0));
	     end;

	if rtq_info.rtq_area_ptr ^= null then
		call release_area_ (rtq_info.rtq_area_ptr);

/* if file was attached then detach it */
	if rtq_info.f_attached then do;
		call iox_$close (rtq_info.fiocb_ptr, (0));
		call iox_$detach_iocb (rtq_info.fiocb_ptr, (0));
		rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b;
	     end;

     end read_tape_and_query_janitor;

/************************************************************************/
%page;
terminate_null_ref_name:  proc ();

/* begin coding */
	code = 0;                               /* prevent code was previously not zero */
	if profile_ptr ^= null then
	     call terminate_file_ (profile_ptr, bit_count, TERM_FILE_TERM, code);
	if code ^= 0 then call com_err_ (code, pname, "Terminating profile segment.");

	return;

end terminate_null_ref_name;
     
/************************************************************************/
%page;
%include rtq_structure_info;
%page;
%include access_mode_values;
%page;
%include terminate_file;
%page;
%include iox_modes;
%page;
%include ssu_prompt_modes;
%include ssu_rp_options;
	dcl     1 local_rpo		 like rp_options;
%include area_info;

     end read_tape_and_query;




		    rtq_.pl1                        07/28/87  1527.0rew 07/28/87  1524.5     1198836



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


/****^  HISTORY COMMENTS:
  1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692),
     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
     convert read_tape_and_query (rtq) nonstandard subsystem to a standard
     ssu_ subsystem.
  2) change(87-07-14,TLNguyen), approve(87-07-14,MCR7701),
     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
     bug fixes.
  3) change(87-07-14,TLNguyen), approve(87-07-14,MCR7727),
     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
     add two new requests: "eof" and "rif".
  4) change(87-07-28,TLNguyen), approve(87-07-28,PBF7701),
     audit(87-07-28,Blair), install(87-07-28,MR12.1-1050):
     PBF to ID1048:  expand file names'declaration from char (32) to char
     (168) and attach output description (specified by -ods) from char (64) to
     char (200).
                                                   END HISTORY COMMENTS */

rtq_: proc ();

/* formated by default */

/* external entries */
	dcl     bcd_to_ascii_	 entry (bit (*), char (*));
	dcl     comp_8_to_ascii_	 entry (bit (*), char (*));
	dcl     cv_dec_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     cv_oct_check_	 entry (char (*), fixed bin (35)) returns (fixed bin (35));
	dcl     date_time_		 entry (fixed bin (71), char (*));
	dcl     ebcdic_to_ascii_	 entry (char (*), char (*));
	dcl     ebcdic8_to_ascii_	 entry (bit (*), char (*));
	dcl     expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
	dcl     ioa_		 entry options (variable);
	dcl     ioa_$rsnnl		 entry options (variable);
	dcl     iox_$attach_name	 entry (char (*), ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     pathname_		 entry (char (*), char (*)) returns (char (168));
	dcl     ssu_$abort_line	 entry () options (variable);
	dcl     ssu_$abort_subsystem	 entry () options (variable);
	dcl     ssu_$arg_count	 entry (ptr, fixed bin);
	dcl     ssu_$arg_ptr	 entry (ptr, fixed bin, ptr, fixed bin);
	dcl     ssu_$get_subsystem_and_request_name entry (ptr) returns (char (72) var);
	dcl     ssu_$print_message	 entry () options (variable);

/* condition */
	dcl     (cleanup, conversion, program_interrupt) condition;

/* builtin */
	dcl     (addr, addrel, bin, char, currentsize, divide, fixed, hbound, index, length, ltrim, mod, null, rtrim,
	        revert, search, substr, translate, unspec) builtin;

/* automatic storage */
	dcl     BINARY_MODE		 fixed bin static options (constant) init (1);
	dcl     LABEL		 (0:6) char (9) int static options (constant) init
				 ("unlabeled", "Multics", "Multics", "GCOS", "IBM", "ANSI", "CP5");
	dcl     NL		 char (1) int static options (constant) init ("
");
	dcl     NINE_MODE		 fixed bin static options (constant) init (3);
	dcl     NUMB_OF_CHARS_PER_WORD fixed bin static options (constant) init (4);
	dcl     YES_FLG		 bit (1) aligned;
	dcl     Nargs		 fixed bin;	/* number of input arguments */
	dcl     al		 fixed bin;	/* argument length */
	dcl     ansid		 bit (1) aligned;	/* ANSI db format */
	dcl     ansi_mode		 fixed bin;	/* ANSI mode */
	dcl     ap		 ptr;		/* argument pointer */
	dcl     arg_dex		 fixed bin;
	dcl     att_desc		 char (200);	/* 168 chars for pathname + 32 chars for "vfile_ " */
	dcl     attach_desc_output	 char (200) varying;
	dcl     bcnt		 fixed bin (24);	/* block count */
	dcl     binck		 bit (1) aligned;	/* binary card */
	dcl     blocksize		 fixed bin (35);	/* block size */
	dcl     (c_b_a,
	        c_c_a,
	        c_e_a,
	        cont,
	        cp5)		 bit (1) aligned;	/* convert bcd; comp8; ebcdic; continuing ; cp5 */
	dcl     code		 fixed bin (35);
	dcl     dec_sw		 bit (1) aligned;	/* DEC switch */
	dcl     direction		 bit (1) aligned;
	dcl     eoj_card		 char (14) static options (constant) init
				 ("$      endjob
");
	dcl     first_record_flg	 bit (1) aligned;
	dcl     g_label		 bit (72) int static options (constant) init /* = "ge  600 btl " in bcd */
				 ("272520200600002022634320"b3);
	dcl     gssf		 bit (1) aligned;	/* Gcos standard system format */
	dcl     (i, j)		 fixed bin;	/* indices */
	dcl     ibm_label		 fixed bin int static options (constant) init (4);
	dcl     ibmv		 bit (1) aligned;	/* IBM vb format */
	dcl     imcv		 bit (1) aligned;	/* suffix name of $ snumb card in Gcos standard format */
	dcl     it_cnt		 fixed bin;	/* count it */
	dcl     iterations		 fixed bin (35);
	dcl     l_cnt		 fixed bin (35);	/* loop count */
	dcl     l_rec		 bit (1) aligned;	/* logical record */
	dcl     l_rec_len		 fixed bin (35);	/* logical record length */
	dcl     last_record_flg	 bit (1) aligned;
	dcl     lrp		 ptr;		/* logical record pointer */
	dcl     mode		 (3) char (7) int static options (constant) init
				 ("binary", "bcd", "nine");
	dcl     mssf		 bit (1) aligned;	/* Multics standard system format */
	dcl     nchars		 fixed bin (21);	/* number of characters */
	dcl     nnl_sw		 bit (1) aligned;	/* no new line switch */
	dcl     n_ops		 fixed bin;	/* number of operations */
	dcl     nunits		 fixed bin (35);	/* number of units */
	dcl     nwds		 fixed bin (35);	/* number of words to dump */
	dcl     open_mode		 fixed bin;
	dcl     order		 char (16);
	dcl     pname		 char (19) int static options (constant) init
				 ("read_tape_and_query");
	dcl     rf		 bit (1) aligned;	/* file requests (e.g. bsf, fsf) */
	dcl     rpt		 bit (1) aligned;	/* space requests (e.g. bsf, bsr, fsf, fsr) */
	dcl     rtq_info_ptr	 ptr;
	dcl     s_filename		 char (32) varying; /* source file name */
	dcl     save_status_code	 fixed bin (35);
	dcl     sci_ptr		 ptr;
	dcl     scode		 fixed bin (35);
	dcl     schar		 fixed bin (35);	/* skip characters */
	dcl     spill		 fixed bin (21);
	dcl     status_story	 char (100) varying;
	dcl     t_stat		 bit (12) aligned;	/* tape status */
	dcl     temp_logical_rec_len	 fixed bin (21);
	dcl     time_string		 char (24);
	dcl     tr_cnt		 fixed bin (35);	/* truncate count */
	dcl     trim_trailing_blanks_log_rec_len fixed bin (21);
	dcl     trunc_sw		 bit (1) aligned;	/* truncate switch */
	dcl     who_asked		 char (32) varying;

/* external static */
	dcl     (error_table_$end_of_info,
	        error_table_$not_closed,
	        error_table_$not_detached,
	        error_table_$tape_error) fixed bin (35) ext;

	dcl     iox_$user_output ptr ext;
	dcl     sys_info$max_seg_size	 fixed bin (35) ext static;
	dcl     tape_status_table_$tape_status_table_ ext static;

/* based */
	dcl     1 ansi_db_lrec	 based (rtq_info.rptr) unaligned, /* template for ansi "DB" formated records */
		2 lrl		 char (4),	/* log rec length in ascii chars */
		2 alrd		 char (l_rec_len),	/* log rec data */
		2 nxt_lrec	 bit (0);		/* to get to nxt record */

	dcl     1 conv_buf		 based (lrp),	/* conversion buffer, no logical records */
		2 skip_char	 char (schar),	/* characters to skip */
		2 conv_dta	 char (rtq_info.rec_len - schar + 1); /* good char data */

	dcl     1 cp5_phy_rec	 based (rtq_info.tptr) aligned, /* cp5 standard tape record */
	        ( 2 pbs		 fixed bin (18) unsigned, /* previous block size */
		2 nky		 fixed bin (18) unsigned, /* number of log records in this block */
		2 first		 bit (1)) unaligned;/* to get to first log record */

	dcl     1 cp5_log_rec	 based (rtq_info.rptr) aligned, /* cp5 variable logical record */
	        ( 2 pad1		 bit (36),	/* not used - yet */
		2 pad2		 fixed bin,	/* ditto */
		2 rlen		 fixed bin (18) unsigned, /* size of record in bytes */
		2 cp5_log_rec_data	 char (1 refer (cp5_log_rec.rlen))) unaligned; /* data bytes in EBCDIC */

	dcl     1 dec_mult		 (it_cnt) based (lrp) aligned, /* convert DEC to Multics word */
	        ( 2 first_32	 bit (32),	/* first 32 bits */
		2 last_4		 bit (4)) unaligned;/* last four bits */

	dcl     1 dec_tape_raw	 based (rtq_info.tptr) aligned, /* strange format for DEC tape */
		2 ps_wd		 (it_cnt) unaligned,/* pseudo DEC word (40 bits) */
		  3 first_32	 bit (32),	/* first 32 bits of word */
		  3 pad		 bit (4),		/* next 4 bits ignored */
		  3 last_4	 bit (4);		/* last 4 bits */

	dcl     1 ibm_log_rec	 based (rtq_info.rptr) unaligned, /* IBM VB log record */
		2 rdw,				/* record data word */
		  3 pad1		 bit (1),
		  3 msl		 bit (8),		/* most sign. 8 bits of length */
		  3 pad2		 bit (1),
		  3 lsl		 bit (8),		/* least sign. 8 bits of length */
		  3 pad3		 bit (18),
		2 ilrd		 char (l_rec_len),	/* ebcdic data */
		2 nxt_lrec	 bit (0);		/* to get to nxt log record */

	dcl     1 ibm_phy_rec	 based (rtq_info.tptr) aligned, /* IBM VB phy record */
	        ( 2 bdw,				/* block data word */
		  3 pad1		 bit (1),
		  3 msl		 bit (8),		/* most sign. 8 bits of length */
		  3 pad2		 bit (1),
		  3 lsl		 bit (8),		/* least sign. 8 bits of length */
		  3 pad3		 bit (18),
		2 iprd		 char (blocksize - 4)) unaligned;

	dcl     1 lrec_cbuf		 based (lrp),	/* logical record template */
		2 skip_char	 char (schar),
		2 chcv_buf	 (it_cnt) char (l_rec_len);

	dcl     1 mult		 based (rtq_info.tptr) unaligned,
		2 lab_id		 bit (36),	/* this will be 670314355245 in octal */
		2 pad		 (7) bit (36),	/* we ignore this */
		2 vol_info	 like volume_identifier; /* mstr.incl.pl1 must be included */

	dcl     1 gcos		 based (rtq_info.tptr) unaligned,
		2 lab_id		 bit (72),	/* this will be "GE  600 BTL " in bcd */
		2 pad		 bit (36),	/* we ignore this */
		2 vol_id		 bit (36);	/* this is in bcd */

	dcl     1 ibm_ansi		 based (rtq_info.tptr) unaligned, /* IBM or ANSI label structure */
		2 lab_id		 bit (32),	/* this will be "VOL1" in ebcdic or 8 bit ascii */
		2 vol_id		 bit (48);	/* this is in ebcdic or 8 bit ascii */

	dcl     1 cp5_lab		 based (rtq_info.tptr) unaligned, /* CP5 label structure */
		2 lab_id		 bit (32),	/* This will be ":LBL" in 8 bit ebcdic */
		2 vol_id		 bit (32);	/* this is 8 bit ebcdic */

	dcl     arg		 char (al) based (ap);

	dcl     bit_buf		 bit (rtq_info.bits) based (rtq_info.tptr); /* tape buffer in bits pointed by tape pointer */

	dcl     char_buf		 char (rtq_info.rec_len) based (rtq_info.tptr); /* tape buffer in characters pointed by tape pointer */

	dcl     cdkbuf		 char (136) based (rtq_info.cdkp);

	dcl     cbuf		 char (rtq_info.buf_size) based (rtq_info.cbufp);

	dcl     cv_buf		 char (rtq_info.cvbl) based (rtq_info.cvbp);

	dcl     gssf_ascii		 char (gc_log_rec.rcw.rsize * 4) based (rtq_info.cvp);

	dcl     lab_buf		 char (rtq_info.rec_len) based (rtq_info.lblp);

	dcl     mult_move		 char (rtq_info.clen) based;

	dcl     1 rtq_info		 aligned like rtq_structure_info based (rtq_info_ptr);

	dcl     rtq_area		 area based (rtq_info.rtq_area_ptr);

	dcl     sentinel		 char (4) based (rtq_info.lblp);

/* like statement */
	dcl     1 ai		 like area_info aligned;

/***************************************************************************/
%page;
set_up: entry (sci_ptr, rtq_info_ptr, code);

/*   initiate variables and area info block.  Establish                    */
/*   cleanup and program_interrupt conditions.  Get an area and save its   */
/*   pointer.  Get temporary segments for rtq subsubsystem.  Attach and    */
/*   open tape using the "tape_nstd_" i/o module.  Set conversion buffer   */
/*   to maximum size.  Determine an user's density.  If the density is     */
/*   valid then report to an user and determine the tape types.  Report    */
/*   the tape type to users.  Invoke "check_mode" internal procedure if    */
/*   the tape type is either IBM label or ANSI label.  Perform the         */
/*   "forward_record" control order to the HDR2 label record and read it   */
/*   in by invoking "read_tape_record" internal procedure.  Check the      */
/*   input/output eof argument value.  If not end of file then report to   */
/*   users and invoke the "valid_label_record".  Report to user, perform   */
/*   the "forward_file" control order and return.  If end of file          */
/*   encountered, report to users, perform the "rewind" control order and  */
/*   return.  If the given density is invalid then set the density to the  */
/*   default density, report to users, and return.                         */

/*   constant */
	dcl     NUMB_OF_BITS_PER_BYTE	 fixed bin static options (constant) init (9);
	dcl     NUMB_OF_BYTES_PER_WORD fixed bin static options (constant) init (4);
	dcl     CP5_label		 bit (32) int static options (constant) init /* ":LBL" in 8 bit ebcdic */
				 ("72D3C2D3"b4);

	dcl     a_label		 bit (32) int static options (constant) init /* "VOL1" in 8 bit ascii (ansi stand label) */
				 ("564F4C31"b4);

	dcl     ansi_label		 fixed bin int static options (constant) init (5);
	dcl     cp5_label		 fixed bin int static options (constant) init (6);
	dcl     i_label		 bit (32) int static options (constant) init /* "VOL1" in 8 bit ebcdic (ibm stand label) */
				 ("E5D6D3F1"b4);

	dcl     (v1_mult_label	 init (1),
	        v3_mult_label	 init (2)) fixed bin int static options (constant);

/* automatic storage */
	dcl     get_line_length	 fixed bin;
	dcl     rcd_volid		 char (32);
	dcl     terminate_read_sw	 bit (1);

/* base */
	dcl     blab		 (0:15) bit (9) unaligned based (addr (rcd_volid));

/*   external entry */
	dcl     define_area_	 entry (ptr, fixed bin (35));
	dcl     get_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     get_line_length_$switch entry (ptr, fixed bin (35)) returns (fixed bin);


/* begin coding */
	mssf = "0"b;				/* initialize Multics standard system format flag */
	rcd_volid = "";
	unspec (ai) = "0"b;				/* clear out area info */
	ai.version = area_info_version_1;		/* set up area info block */
	ai.control.extend = "1"b;
	ai.control.zero_on_alloc = "1"b;
	ai.owner = pname;
	ai.size = sys_info$max_seg_size;
	ai.version_of_area = area_info_version_1;
	ai.areap = null;

/* set up clean up handler */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

/* establish program_interrupt (pi) handler */
	on program_interrupt goto SET_UP_EXIT;

/* find terminal line length */
	get_line_length = get_line_length_$switch (null, scode);
	if get_line_length < 118 & scode = 0 then
	     rtq_info.short_output_flg = "1"b;		/* set short output switch */
	else rtq_info.short_output_flg = "0"b;		/* otherwise long output */

/* get an area */
	call define_area_ (addr (ai), code);
	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "Cannot define an area");
		return;
	     end;

	rtq_info.rtq_area_ptr = ai.areap;

/* get a temporary segment for our tape buffer */
	call get_temp_segment_ (pname, rtq_info.tptr, code);
	if code ^= 0 then do;			/* can't alocate buffer */
		call ssu_$print_message (sci_ptr, code, "Getting temporary tape buffer segment");
		call detach_tape_file (sci_ptr, rtq_info_ptr);
		return;
	     end;


/* allocate intermediate buffers */
	allocate cv_buf in (rtq_area);
	allocate cdkbuf in (rtq_area);
	allocate cbuf in (rtq_area);

/* attach and open tape using the "tape_nstd_" io module */
TRY_AGAIN:
	call iox_$attach_name ("tape_sw", rtq_info.tiocb_ptr, (rtq_info.tape_atd), null, code);
	if code ^= 0 then do;
		if code = error_table_$not_detached then do;
			call iox_$detach_iocb (rtq_info.tiocb_ptr, code);
			if code ^= error_table_$not_closed then do;
				call ssu_$print_message (sci_ptr, code);
				return;
			     end;
			else do;
				call iox_$close (rtq_info.tiocb_ptr, (0));
				goto TRY_AGAIN;
			     end;
		     end;
		else do;
			call ssu_$print_message (sci_ptr, code, "^/ Attempting to attach tape.");
			call detach_tape_file (sci_ptr, rtq_info_ptr); /* go cleanup */
			return;
		     end;
	     end;

	call iox_$open (rtq_info.tiocb_ptr, Sequential_input, "0"b, code); /* open for seq. input */
	if code ^= 0 then do;
		call ssu_$print_message (sci_ptr, code, "^/Opening tape for sequential input");
		call detach_tape_file (sci_ptr, rtq_info_ptr);
		return;
	     end;

/* set conversion buffer to max size */
	rtq_info.cvbl = divide (rtq_info.buf_size * NUMB_OF_BITS_PER_BYTE, NUMB_OF_BYTES_PER_WORD, 21, 0);

/* loop through the array index from 1 to 5 to find the matched density value if an user specifies a density value */
	j = hbound (rtq_info.density, 1);
	terminate_read_sw = "0"b;
	do i = 1 to j while (^terminate_read_sw);
	     call iox_$control (rtq_info.tiocb_ptr, (rtq_info.density (i)), null, scode);
	     if scode = 0 then do;
		     call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size, rtq_info.rec_len, code);
		     if code ^= error_table_$tape_error then do; /* if some other type of error, then warn users */
			     if (code ^= 0) & (code ^= error_table_$end_of_info) then
				call ssu_$print_message (sci_ptr, code, "^/Attempting to determine density of tape volume ^a", rtq_info.tape_name);

			     terminate_read_sw = "1"b;/* set terminate condition */
			end;
		     call iox_$control (rtq_info.tiocb_ptr, "rewind", null, scode);
		end;				/* scode = 0 */
	end;					/* do i = 1 to 5 */

/* use the default density if could not find the valid density; otherwise, get it */
	rtq_info.tmr = terminate_read_sw;

	if ^rtq_info.tmr | (code ^= 0 & code ^= error_table_$end_of_info) then do;
		if rtq_info.ddec ^= 0 then rtq_info.c_den = "d" || ltrim (char (rtq_info.ddec)); /* if density was specified.. */
		else rtq_info.c_den = rtq_info.density (1); /* otherwise use default */
						/* perform a density control order on an i/o switch */
		call iox_$control (rtq_info.tiocb_ptr, (rtq_info.c_den), null, scode);
						/* display a warning message */
		call ssu_$print_message (sci_ptr, 0,
		     "Unable to determine density of tape volume ^a.^/     Density is currently set to ^a (bpi).",
		     rtq_info.tape_name, substr (rtq_info.c_den, 2));

		code = 0;
		scode = 0;			/* since it is not an error, so want to continue */
	     end;

/* report the density to users and determine the tape label types */
	else do;
		rtq_info.c_den = rtq_info.density (i - 1); /* save current density */

		call ioa_ ("Tape density is ^a bpi", substr (rtq_info.density (i - 1), 2));

		call determine_tape_label_types;

		if rtq_info.return_subsys_loop_flg then do;
			rtq_info.return_subsys_loop_flg = "0"b;
			return;
		     end;
	     end;

SET_UP_EXIT:

	return;


/***************************************************************************/
%page;
bof_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt conditions.  Invoke the         */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify any control arguments.  Invoke the             */
/* "process_control_order" internal procedure to the beginning of the file */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto BOF_EXIT;

	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "Usage:  bof");
		return;
	     end;

/* initialization */
	scode = 0;
	l_cnt = 1;
	rf, rpt = "1"b;
	direction = "0"b;
	order = "begin_file";

/* process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

BOF_EXIT:
	return;

/***************************************************************************/
%page;
bsf_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Invoke the           */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify two or more control arguments.                 */
/* Process the specified control argument.  Invoke the                     */
/* "process_control_order" internal procedure to backspace N files.        */
/* The default is to backspace 1 file.                                     */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto BSF_EXIT;

/* initialization */
	l_cnt = 1;
	scode = 0;
	rf, rpt = "1"b;
	direction = "0"b;
	order = "backspace_file";

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs >= 2 then do;
ERROR_BSF:
		call ssu_$print_message (sci_ptr, scode, "^/     Usage:  bsf {n}");
		return;
	     end;

/* then validate them */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     l_cnt = cv_dec_check_ (arg, scode);
	     if scode ^= 0 then goto ERROR_BSF;
	end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

/* must reset the flag fields of the "rtq_info" structure before returning to rtq request loop */
	rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;

BSF_EXIT:
	return;

/***************************************************************************/
%page;
bsr_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Invoke the           */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify two or more 2 control arguments.               */
/* Process the specified control argument.  Invoke the                     */
/* "process_control_order" internal procedure to backspace N records.      */
/* The default is to backspace 1 record.                                   */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto BSR_EXIT;

/* initialization */
	l_cnt = 1;
	scode = 0;
	rpt = "1"b;
	rf, direction = "0"b;
	order = "backspace_record";

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs >= 2 then do;
ERROR_BSR:
		call ssu_$print_message (sci_ptr, scode, "Usage:  bsr {N}");
		return;
	     end;

/* then validate them */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     l_cnt = cv_dec_check_ (arg, scode);
	     if scode ^= 0 then goto ERROR_BSR;
	     else ;
	end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

BSR_EXIT:
	return;

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

%page;
density_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Invoke the           */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify no CA or two or more control arguments.        */
/* Validate the control argument which is the density.  Display an usage   */
/* message for the invalid density.  Otherwise, invoke the                 */
/* "process_control_order" internal procedure to perform the specified     */
/* density control order.                                                  */


	dcl     array_index		 fixed bin;
	dcl     match		 bit (1) aligned;

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto DENSITY_EXIT;

/* initialization */
	l_cnt = 1;
	match = "0"b;
	scode = 0;
	rpt, rf, direction = "0"b;			/* reset command flags */

/* find the number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs = 0 | Nargs >= 2 then do;
ERROR_DENSITY:
		call ssu_$print_message (sci_ptr, scode, "Usage:  density (den) <6250 | 1600 | 800 | 556 | 200>");
		return;
	     end;

/* then validate the tape density */
	call ssu_$arg_ptr (sci_ptr, Nargs, ap, al);
	do array_index = 1 to 5 while (^match);
	     if arg = substr (rtq_info.density (array_index), 2, 4) then
		match = "1"b;
	end;
	if ^match then
	     goto ERROR_DENSITY;
	else do;
		rtq_info.ddec = cv_dec_check_ (arg, scode);
		if scode ^= 0 then goto ERROR_DENSITY;
		else rtq_info.c_den, order = "d" || ltrim (char (rtq_info.ddec));
	     end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

DENSITY_EXIT:

	return;

/***************************************************************************/
%page;
dot_request: entry (sci_ptr, rtq_info_ptr);

/* displays the request name read_tape_and_query with its short name, rtq, */
/* in parentheses.                                                         */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto RETURNS_TO_SUBSYS;

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
		return;
	     end;

/* response to user's request */
	call ioa_ ("read_tape_and_query (rtq):  Reading tape volume ""^a"" in ""^a"" mode.^/                            Currently positioned to Physical file ^d, record ^d.",
	     rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);

RETURNS_TO_SUBSYS:

	return;

/***************************************************************************/
%page;
dump_record_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Initialize           */
/* intermediate variables.  Get optional control arguments and process     */
/* them by invoking the "set_dump_fmt" internal procedure.                 */
/* Dump the tape record in the requested format by invoking the            */
/* "dump_segment_" standard system subroutine.                             */

/* external entry */
	dcl     dump_segment_	 entry (ptr, ptr, fixed bin, fixed bin (35), fixed bin (35), bit (*));

/* automatic storage */
	dcl     NUMB_OF_BITS_PER_CHAR	 fixed bin static options (constant) init (9);
	dcl     NUMB_OF_BITS_PER_WORD	 fixed bin static options (constant) init (36);
	dcl     doffset		 fixed bin;	/* dump off set */
	dcl     dump_index		 fixed bin;
	dcl     format		 (4) bit (11);
	dcl     n_words_specified_flg	 bit (1) aligned;
	dcl     ndumps		 fixed bin;	/* number of dumps */
	dcl     offset_specified_flg	 bit (1) aligned;

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto WANTS_TO_EXIT;

/* validate data */
	if ^rtq_info.buf_ful then do;			/* we don't have any data yet */
		call ssu_$print_message (sci_ptr, 0, "Record buffer empty");
		return;
	     end;

/* set up for dump request */
	scode = 0;
	ndumps = 1;				/* set defaults first (entire buffer in octal format) */
	doffset = 0;
	format (1) = "01000000000"b;
	nwds = divide (rtq_info.rec_len * NUMB_OF_BITS_PER_CHAR + 35, NUMB_OF_BITS_PER_WORD, 35, 0);
	offset_specified_flg, n_words_specified_flg = "0"b;

/* find number of arguments */
	call ssu_$arg_count (sci_ptr, Nargs);

/* then validate them */
	do arg_dex = 1 to Nargs;			/* user specifies some input args */
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process each argument */
	     if substr (arg, 1, 1) ^= "-" then do;	/* some number spec */

		     if ^offset_specified_flg then do;	/* offset spec must be first */
			     offset_specified_flg = "1"b; /* set switch so we don't come back */
			     doffset = cv_oct_check_ (arg, scode); /* convert ascii to oct */
			     if scode ^= 0 then do;
ERROR_DUMP:
				     call ssu_$print_message (sci_ptr, scode,
					"^/     Usage:  dump {offset (oct)} {n_words (oct)} {-bcd} {-ascii} {-ebcdic} {-hex}");
				     return;
				end;

			     nwds = nwds - doffset;	/* correct number of words to dump */
			end;			/* if ^offset_specified_flg then do */

		     else if ^n_words_specified_flg then do; /* user wants to specify number of words */
			     n_words_specified_flg = "1"b; /* set switch so we won't be back */
			     nwds = cv_oct_check_ (arg, scode);
			     if scode ^= 0 then goto ERROR_DUMP; /* tell user what to do, he goofed */
			end;			/* else if ^n_words_specified_flg */

		     else goto ERROR_DUMP;		/* ditto */
		end;				/* if substr (arg, 1, 1) ^= "-"  */

	     else if arg = "-bcd" then /* requesting bcd dump */
		call set_dump_fmt ("01010000000"b);

	     else if arg = "-ascii" then /* user requesting ascii dump */
		call set_dump_fmt ("01001000000"b);

	     else if arg = "-ebcdic" then do;		/* user wants ebcdic dump */
		     if rtq_info.c_mode = 3 then /* if in 9 bit mode */
			call set_dump_fmt ("01000010000"b);
		     else call set_dump_fmt ("01000001000"b); /* else 8 bit mode */
		end;

	     else if arg = "-hex" then do;		/* user wants hex dump */
		     if rtq_info.c_mode = 3 then /* if in 9 bit mode */
			call set_dump_fmt ("01000000001"b);
		     else call set_dump_fmt ("01000000010"b); /* else 8 bit mode */
		end;

	     else goto ERROR_DUMP;			/* user goofed tell him how to use dump request */
	end;					/* do arg_dex = 1 to Nargs */

	if ndumps > 1 then ndumps = ndumps - 1;		/* correct number of dumps */

	do dump_index = 1 to ndumps;			/* dump requested number of formats */
	     call ioa_ (" ");
	     call dump_segment_ (iox_$user_output, addrel (rtq_info.tptr, doffset), 0, 0, nwds, format (dump_index));
	end;

WANTS_TO_EXIT:

	return;



set_dump_fmt: proc (fmt);

/* sets dump type */

	dcl     fmt		 bit (11);

/* begin coding */
	format (ndumps) = fmt;			/* set desired format */
	ndumps = ndumps + 1;			/* increment number of dumps to do */

	if ndumps > (hbound (format, 1) + 1) then /* user wants to many */
	     goto ERROR_DUMP;			/* tell him what he can do */

     end set_dump_fmt;

/***************************************************************************/
%page;
eof_request: entry (sci_ptr, rtq_info_ptr);

/* positions to the end of the current physical tape file, after the last   */
/* record.  Establish cleanup and program_interrupt handlers.  No           */
/* optional control arguments are allowed.  Perform "forward_record"        */
/* control orders until end of file encountered.  Note that the current     */
/* record is incremented by one until end of file reached.                  */
/* Then perform "backspace_record" order to position before end of file     */
/* mark since the last forward record order positioned the tape after end   */
/* of file mark.  Report to users after the request is successfully done.   */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto SUBSYSTEM_RETURNED;

/* display an error message if any optional control argument is specified */
	call ssu_$arg_count (sci_ptr, Nargs);

	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "Usage:  eof");
		return;
	     end;

/* initialization */
	rtq_info.eof_request_flg = "1"b;
	scode = 0;
	order = "forward_record";
	rpt = "1"b;
	direction = "1"b;
	rf = "0"b;
	l_cnt = 1;

/* perform several "forward_record" orders until end of current file reached */
	do while (scode ^= error_table_$end_of_info);
	     call process_control_order (order, rpt, direction, rf, l_cnt);

	     if scode = 0 then
		rtq_info.c_rec = rtq_info.c_rec + 1;	/* to find the last record in the current file */

	     if scode = error_table_$tape_error then do;	/* exit loop if tape error occured */
		     call ssu_$print_message (sci_ptr, scode,
			"Attempting to perform ""forward_record"" order");
		     rtq_info.eof_request_flg = "0"b;
		     return;
		end;
	end;

/* perform the "backspace_record" control order to position to the end of the current file */
	direction = "0"b;				/* must reset intermediate variables */
	rpt = "0"b;
	rf = "0"b;
	l_cnt = 1;
	order = "backspace_record";

	call process_control_order (order, rpt, direction, rf, l_cnt);

/* report to users after the "eof" request is successfully done */
	if rtq_info.c_rec = 1 then
	     /* case of an empty file or a file has no data record */
	     call ssu_$print_message (sci_ptr, 0,
		"Positioned the tape to the beginning of the current file # ^d which has no data record.", rtq_info.c_file);

/* case of a file contains 1 data record or more */
	else call ssu_$print_message (sci_ptr, 0,
		"Positioned the tape to the end of the current file # ^d, after the last record # ^d.",
		rtq_info.c_file, rtq_info.c_rec - 1);

	rtq_info.one_eof = "0"b;			/* must reset these flags before returning to rtq request loop */
	rtq_info.eof_request_flg = "0"b;

SUBSYSTEM_RETURNED:
	return;

/****************************************************************************/
%page;
fsf_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Invoke the           */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify at least 2 control arguments.                  */
/* Process the specified control argument.  Invoke the                     */
/* "process_control_order" internal procedure to forward space N files.    */
/* The default is to forward space 1 file.                                 */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto RETURNS_TO_REQUEST_LOOP;

/* initialization */
	scode = 0;
	l_cnt = 1;
	direction, rpt, rf = "1"b;
	order = "forward_file";

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs >= 2 then do;
ERROR_FSF:
		call ssu_$print_message (sci_ptr, scode, "Usage:  fsf {N}");
		return;
	     end;

/* then validate them */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     l_cnt = cv_dec_check_ (arg, scode);
	     if scode ^= 0 then goto ERROR_FSF;
	     else ;
	end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

RETURNS_TO_REQUEST_LOOP:

	return;

/*****************************************************************************/
%page;
fsr_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Invoke the           */
/* "ssu_$arg_count" standard system subroutine.  Print out an usage        */
/* message if users specify more than one control arguments.               */
/* Process the specified control argument.  Invoke the                     */
/* "process_control_order" internal procedure to forward space N record.   */
/* The default is to forward space 1 record.                               */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr); /* set up clean up handler */

	on program_interrupt goto FSR_RETURN;

/* initialization */
	scode = 0;
	l_cnt = 1;
	direction, rpt = "1"b;
	rf = "0"b;
	order = "forward_record";

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs >= 2 then do;
ERROR_FSR:
		call ssu_$print_message (sci_ptr, scode, "Usage:  fsr {N}");
		return;
	     end;

/* then validate them */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     l_cnt = cv_dec_check_ (arg, scode);
	     if scode ^= 0 then goto ERROR_FSR;
	     else ;
	end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

FSR_RETURN:
	return;

/*****************************************************************************/
%page;
list_tape_contents: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Initialize both        */
/* intermediate global and local variables.  Find terminal line length.      */
/* Get optional control arguments and process them.  Position tape to the    */
/* beginning of tape if not already there.  If the tape type is either       */
/* MULTICS or GCOS tape then set mode to binary mode.  Set to nine mode for  */
/* IBM or ANSI tape.  Report the mode to users.  Read in each tape record in */
/* the tape until end of tape is encountered:  this can be done by invoking  */
/* the "read_tape_record" internal procedure.  Set up nessary things if      */
/* want to return to subsystem request loop.  If not end of file then if     */
/* this is the first record of the file then report the current file read to */
/* users.  Determine the record type.  If the record read is not a label     */
/* record then if the record read is the first record of the file then       */
/* assign the number of bits to last record length, reset the number of      */
/* records to zero, and increment logical file number by one.  Report to     */
/* users if tape type is a label tape or Multics tape.  If the number of     */
/* bits of the record read is the same as the last record length then        */
/* increment the number of record by one.  Otherwise, report to users.       */
/* If the record read is a nonlabel record then assign zero to the last      */
/* record length.  If end of file is encountered then report to user, reset  */
/* record number and logical file flag and set up appropriate mode for the   */
/* next file to be read.  When end of tape is encountered, perform the       */
/* "rewind" control order to the beginning of tape and then report to users. */

	dcl     logical_file_num	 fixed bin;
	dcl     label_flg		 bit (1) aligned;
	dcl     last_length		 fixed bin;
	dcl     logical_file_flg	 bit (1) aligned;
	dcl     long_list_flg	 bit (1) aligned;
	dcl     nrecords		 fixed bin (35);
	dcl     unlabeled		 fixed bin int static options (constant) init (0);

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto SUBSYSTEM_REQUEST_LOOP;

/* clear global switches */
	scode = 0;
	mssf = "0"b;
	iterations = 1;				/* set default iterations to 1 */
	rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.set_bin, rtq_info.set_nine, rtq_info.two_eofs = "0"b;

/* initialize local flags and variables */
	long_list_flg, label_flg, logical_file_flg = "0"b;
	logical_file_num, last_length, nrecords = 0;

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);

/* process optional control arguments */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);/* process them */

	     if arg = "-long" | arg = "-lg" then long_list_flg = "1"b; /* user wants long list */

	     else if arg = "-label" | arg = "-lbl" then
		if rtq_info.l_type = unlabeled then do; /* illegal on unlabeled tapes */
			call ssu_$print_message (sci_ptr, 0, """-label"" argument not allowed on unlabeled tapes");
			return;
		     end;
		else label_flg = "1"b;		/* user only wants label rcds */

	     else do;
		     call ssu_$print_message (sci_ptr, 0, "Usage:  list_tape_contents (ltc) {-long (-lg)} {-label (-lbl)}");
		     return;
		end;
	end;					/* do arg_dex = 1 to Nargs */

/* position to bot if not already there */
	if rtq_info.c_rec ^= 1 | rtq_info.c_file ^= 1 then
	     call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);
	else ;

/* for Multics or Gcos tape, set to binary mode */
	if rtq_info.l_type > 0 & rtq_info.l_type <= 3 then
	     call check_mode (BINARY_MODE);

/* for IBM or ANSI tape, set to nine mode */
	else if rtq_info.l_type > 3 then
	     call check_mode (NINE_MODE);

/* report to users */
	call ioa_ ("Listing tape contents of tape volume ^a in ^a mode.^/     Starting at BOT (physical file# 1, record# 1)^/     ",
	     rtq_info.tape_name, mode (rtq_info.c_mode));

/* read until the end of tape is encountered */
	do while (^rtq_info.two_eofs);
	     call read_tape_record ("skip", rtq_info.eof, "1"b, mssf); /* read next record */

	     if rtq_info.return_subsys_loop_flg then do;
		     rtq_info.return_subsys_loop_flg = "0"b;
		     revert cleanup;
		     call ssu_$abort_line (sci_ptr);
		end;

	     if ^rtq_info.eof then do;		/* if not end of file */

		     if rtq_info.c_rec = 2 then /* if first  record of this file */
			call ioa_ ("Physical tape file # ^d.", rtq_info.c_file);

		     if ^valid_label_record (long_list_flg) then do; /* and not label record */

			     if rtq_info.c_rec = 2 then do; /* if this is first record of file */
				     last_length = rtq_info.bits; /* set for equal record processing */
				     nrecords = 0;
				     logical_file_num = logical_file_num + 1; /* increment logical file number */

				     if rtq_info.l_type > 1 then do; /* if not unlabeled or Multics tape */
					     call ioa_ ("Logical tape file # ^d.^[^/     ^]", logical_file_num, ^label_flg);
					     logical_file_flg = "1"b;
					end;
				     else call ioa_ (" "); /* otherwise just write blank line */
				end;		/* first record of the file */

			     if last_length = rtq_info.bits then /* this record length is the same as the last record length */
				nrecords = nrecords + 1; /* just tally it */
			     else do;		/* otherwise, display a message */
				     if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */

				     if ^label_flg then call record_information (nrecords, (last_length), "1"b);

				     last_length = rtq_info.bits; /* restart tally */
				     nrecords = 0;
				end;		/* the current record length is different from the last record length */
			end;			/* if ^valid_label_record (long_list_flg) */

		     else last_length = 0;		/* a label record */
		end;				/* if ^eof */
	     else do;				/* tape end of file */
		     if last_length > 0 & ^rtq_info.two_eofs then do; /* only display valid records */
			     if nrecords = 0 then nrecords = 1; /* set up for at least 1 record */

			     if ^label_flg then call record_information (nrecords, (last_length), "1"b);
			end;

		     call ioa_ ("End of physical tape file # ^d, ^[(^a # ^d),^[^/     ^; ^]^;^3s^]^a:  ^d.^/     ",
			rtq_info.c_file - 1, logical_file_flg, "logical tape file", logical_file_num,
			rtq_info.short_output_flg, "total records read", rtq_info.c_rec - 1);

		     logical_file_flg = "0"b;
		     rtq_info.c_rec = 1;		/* reset record number */

		     if rtq_info.set_bin & ^label_flg then do; /* if we need to switch next file to bin mode */
			     call check_mode (BINARY_MODE);
			     call ioa_ (" ");	/* write blank line */
			     rtq_info.set_bin = "0"b; /* reset switch */
			end;
		     else if rtq_info.set_nine & ^label_flg then do; /* switch back to nine mode */
			     call check_mode (NINE_MODE);
			     call ioa_ (" ");	/* write blank line */
			     rtq_info.set_nine = "0"b;/* reset switch */
			end;			/* else if */
		end;				/* eof */
	end;					/* do while (^two_eofs) */

/* position to beginning of tape (bot) */
	call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);

/* report to users */
	call ioa_ ("Logical end of tape, positioning to BOT");

SUBSYSTEM_REQUEST_LOOP:

	return;

/*****************************************************************************/
%page;

mode_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Get and process the    */
/* optional control argument.  Perform the specified mode control order by   */
/* invoking the "process_control_order" internal procedure.  Note that if    */
/* control argument is given then set "binary" mode as the defaulf mode.     */

	dcl     mode_dex		 fixed bin;

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto WANTS_TO_RETURN;

/* initialization */
	scode = 0;
	l_cnt = 1;				/* 1 iteration default */
	rpt, rf, direction = "0"b;			/* reset command flags */

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs >= 2 then do;
ERROR_MODE:
		call ssu_$print_message (sci_ptr, 0, "Usage:  mode <bcd | bin | nine>");
		return;
	     end;

/* then validate them */
	if Nargs = 0 then do;
		order = "binary";			/* default mode */
		rtq_info.c_mode = 1;		/* subscript of "bin" mode value */
	     end;
	else ;

	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     if arg = "bcd" | arg = "bin" | arg = "nine" then do;
		     do mode_dex = 1 to 3;		/* try to find the right mode */
			if substr (arg, 1, 3) = substr (mode (mode_dex), 1, 3) then
			     rtq_info.c_mode = mode_dex;
			else ;
		     end;
		     order = mode (rtq_info.c_mode);
		end;
	     else goto ERROR_MODE;
	end;

/* go process control order */
	call process_control_order (order, rpt, direction, rf, l_cnt);

WANTS_TO_RETURN:

	return;

/***************************************************************************/
%page;
position_request: entry (sci_ptr, rtq_info_ptr);

/* The rtq "position" request displays the current physical tape file and  */
/* record position to the user.                                            */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto SUBSYS_QUERY;

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "No argument is allowed for this request.");
		return;
	     end;

/* response to user's request */
	call ssu_$print_message (sci_ptr, 0,
	     "Reading tape volume ""^a"" in ""^a"" mode.^/Currently positioned to physical file ^d, record ^d.",
	     rtq_info.tape_name, mode (rtq_info.c_mode), rtq_info.c_file, rtq_info.c_rec);

SUBSYS_QUERY:

	return;

/*****************************************************************************/
%page;

quit_request: entry (sci_ptr, rtq_info_ptr);

/* returns to the command line */

	call ssu_$abort_subsystem (sci_ptr, 0);

	return;

/*****************************************************************************/
%page;
read_file_request: entry (sci_ptr, rtq_info_ptr);

/* reads the current tape file into the segment described by the optional    */
/* control argument:  Initialize intermediate global and local variables.    */
/* Detach the file if already attached.  Get and process optional control    */
/* arguments.  Check for argument inconsistencies.  Perform the              */
/* "begin_file" control order to position to the beginning of the file if    */
/* not already there.  Do 1 to multilple files if was asked while not end of */
/* tape mark.  Note that read in one file (by default).  Report the          */
/* current file which will be read in to the user.  Set the open mode to the */
/* default mode.  If the user wants output attach description then query the */
/* user for it by invoking the "get_output_descript_and_attach" internal     */
/* procedure.  Invoke the " read_in_the_entire_file" internal procedure      */
/* to read in the entire current file.  Check essential flags.  If we have   */
/* written file already then increment file name by one, expand this file    */
/* name and reset the written file switch.  Read in the next file and do     */
/* the same operations until end of tape mark is encountered.  Finally,      */
/* invoke the "detach_file_if_attached" internal procedure if the "-extend"  */
/* is specified to detach the file if already attached.   Return to the      */
/* subsystem request.                                                        */

	dcl     conversion_flg	 bit (1) aligned;

/* begin coding */
	conversion_flg, first_record_flg, last_record_flg = "0"b;

/* set up cleanup handler and program_interrupt (pi) command */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto RETURN;

	rtq_info.return_subsys_loop_flg = "0"b;		/* make the read_record request happy */

/* the following flgs of "rtq_info" structure must reset so that if users already deleted some data record */
/* in specified files then his can read them back beyond the tape mark */
	rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;

	rtq_info.atd_sw, rtq_info.extend_sw, rtq_info.fw_file, rtq_info.last_job_deck_flg, rtq_info.set_bin = "0"b;
	rtq_info.filename = "";

/* find number of arguments */
	call ssu_$arg_count (sci_ptr, Nargs);

/* set up for processing input arguments */
	scode = 0;
	iterations = 1;				/* set default iteration set to 1 */
	s_filename = "";
	prptr, lrp = rtq_info.tptr;			/* set equivilent pointers */
	n_ops, schar = 0;
	cont, trunc_sw, cp5, ibmv, ansid, dec_sw, gssf, mssf, nnl_sw, l_rec, c_e_a, c_b_a, c_c_a, imcv = "0"b;

/* just in case we had a file attached */
	call detach_file_if_attached;

/* process optional control arguments */
	call read_file_get_control_args;
	if scode ^= 0 | rtq_info.return_subsys_loop_flg then
	     goto SUBSYSTEM_LOOP_RETURN;

/* check for argument inconsistancies */
	if (n_ops > 1) & ^(l_rec & (c_e_a | c_b_a | c_c_a)) then do;
		call ssu_$print_message (sci_ptr, 0, "Inconsistent combination of optional control arguments.");
		return;
	     end;

/* position to the beginning of the tape file */
	if rtq_info.c_rec > 1 then
	     call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1);

/* read multiple files if required */
	do nunits = 1 to iterations while (^rtq_info.two_eofs);

	     call ioa_ ("Reading tape file # ^d in ^a mode", rtq_info.c_file, mode (rtq_info.c_mode));

	     open_mode = Stream_output;		/* set open mode to default mode */
						/* if users want output attach description then ask for it */
	     if (rtq_info.atd_sw & rtq_info.fw_file) | (rtq_info.atd_sw & nunits = 1) then do;
		     call get_output_descript_and_attach;

		     if rtq_info.return_subsys_loop_flg then
			goto SUBSYSTEM_LOOP_RETURN;
		end;

/* read in the entire tape file */
	     call read_in_the_entire_file;

	     if conversion_flg then return;

	     if rtq_info.return_subsys_loop_flg then do;

SUBSYSTEM_LOOP_RETURN:
		     rtq_info.return_subsys_loop_flg = "0"b;
		     return;
		end;

/* if we have written file already */
	     if rtq_info.fw_file & ^rtq_info.extend_sw then do;

		     if s_filename = "" then
			s_filename = rtq_info.filename; /* save filename on first iteration */

		     rtq_info.filename = rtrim (s_filename) || "." || ltrim (char (nunits + 1)); /* increment file name */

		     if ^valid_pathname ((rtq_info.filename), "") then do;
			     call ssu_$print_message (sci_ptr, scode,
				"^/     Expanding pathname for file name ""^a""", rtq_info.filename);
			     return;
			end;

		     rtq_info.fw_file = "0"b;		/* reset switch */
		end;				/* if fw_file & ^extend_sw  */

	end;					/* do nunits = 1 to iterations while (^two_eofs) */

/* if this is end, detach it */
	if rtq_info.extend_sw then
	     call detach_file_if_attached;		/* just in case we had a file attached */

RETURN:
	return;

/***************************************************************************/
%page;
read_record_request: entry (sci_ptr, rtq_info_ptr);

/* reads the current record into a temporary buffer.                       */
/* Establish cleanup and program_interrupt handlers.  Initialize           */
/* intermediate global and local variables.  Find the terminal line        */
/* length.  Get and process optional control arguments.                    */
/* Do 1 to N records  while not end of tape mark .                         */
/* Report the current record of the file to user before reading it in.     */
/* Invoke the "read_tape_record" internal procedure to read in the tape    */
/* record.  If not end of file then report information of each record read */
/* to user.  Read in the next record and do the same operations until      */
/* end of tape mark is encountered.  Return to the subsystem request.      */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto SUBSYS_REQUEST_LOOP;

	rtq_info.return_subsys_loop_flg = "0"b;		/* make the read_record request happy */

/* the following flgs of "rtq_info" structure must be reset so that if users already deleted some data record */
/* from specified files then he can read them back beyond the tape mark */
	rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;

/* initialize global variables */
	scode = 0;				/* must initialize scode value */
	mssf = "0"b;				/* reset Multics standard system format flag */
	iterations = 1;				/* set default iteration set to 1 */

/* find number of input arguments */
	call ssu_$arg_count (sci_ptr, Nargs);

/* then process them */
	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     if arg = "-count" | arg = "-ct" then do;	/* user wants to read mutiple rcds */
		     if arg_dex < Nargs then do;
			     arg_dex = arg_dex + 1;
			     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
			     iterations = cv_dec_check_ (arg, scode); /* check for rdrec iterations */
			     if scode ^= 0 then goto ERROR_RDREC;
			end;
		     else goto ERROR_RDREC;		/* missing N for -count */
		end;				/* -count (-cnt) */
	     else do;				/* no other control arg allowed */
ERROR_RDREC:
		     call ssu_$print_message (sci_ptr, scode, "^/     Usage:  read_record (rdrec) {-count (-ct) N}");
		     return;
		end;

	end;					/* do arg_dex = 1 to Nargs */

	do nunits = 1 to iterations while (^rtq_info.two_eofs);

	     call ssu_$print_message (sci_ptr, 0, "Reading record ^d, File ^d in ^a mode", rtq_info.c_rec,
		rtq_info.c_file, mode (rtq_info.c_mode));

	     call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* go read tape record */

	     if rtq_info.return_subsys_loop_flg then do;
		     rtq_info.return_subsys_loop_flg = "0"b;
		     return;
		end;

	     if ^rtq_info.eof then
		call record_information (1, rtq_info.bits, "0"b); /* display record length info */
	end;					/* do nunits = 1 to iterations while (^two_eofs) */

SUBSYS_REQUEST_LOOP:
	return;

/***************************************************************************/
%page;
records_in_file_request: entry (sci_ptr, rtq_info_ptr);

/* is a request which will report to users the number of records in the    */
/* current file.  Establish cleanup and program_interrupt handlers.        */
/* Report to users if any optional control argument is specified.          */
/* Set up for reading records in the current file.  Read them in until     */
/* end of file encountered.  Report the total records counted and the tape */
/* position to users.  Invoke the "process_control_order" existing         */
/* internal procedure to backspace to the original tape position.  Reset   */
/* the "one_eof" and "records_in_file_flg" flag fields of the "rtq_info"   */
/* structure before returning to the rtq request loop.                     */

	dcl     end_file_flg	 bit (1) aligned;
	dcl     numb_of_recs_to_be_backspaced fixed bin;
	dcl     save_current_record	 fixed bin;
	dcl     save_current_file	 fixed bin;

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto RETURNED;

	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "Usage:  records_in_file, rif");
		return;
	     end;

/* set up for reading records of the current file */
	rtq_info.eov, rtq_info.two_eofs, rtq_info.one_eof = "0"b; /* must reset in case they were previously set */
	scode = 0;
	rtq_info.records_in_file_flg = "1"b;
	rtq_info.return_subsys_loop_flg = "0"b;		/* make the records_in_file request happy */
	save_current_record = rtq_info.c_rec;
	save_current_file = rtq_info.c_file;
	end_file_flg = "0"b;
	mssf = "0"b;

/* read in each record in the current file until end of file encountered */
	do while (^end_file_flg);
	     call read_tape_record ("skip", end_file_flg, "1"b, mssf);
	end;

/* report the number of records counted in the current file */
	call ioa_ ("The current file # ^d contains ^d record^[s^]." ||
	     "^/Repositioned the tape to its original position:  record # ^d, file # ^d.", save_current_file,
	     rtq_info.c_rec - 1, (rtq_info.c_rec > 1), save_current_record, save_current_file);

	rtq_info.c_file = rtq_info.c_file - 1;		/* the actual current file number */

/* perform the "backspace_record" control order to its original position */
	order = "backspace_record";
	rpt = "1"b;
	direction = "0"b;
	rf = "0"b;
	numb_of_recs_to_be_backspaced = rtq_info.c_rec - save_current_record;

/* case of file containing no data record */
	if numb_of_recs_to_be_backspaced = 0 then
	     call iox_$control (rtq_info.tiocb_ptr, order, null, (0));

/* case of a file containing 1 data record or more */
	else call process_control_order (order, rpt, direction, rf, (numb_of_recs_to_be_backspaced));

	rtq_info.one_eof = "0"b;			/* reset after the tape is repositioned to its original position */

	rtq_info.records_in_file_flg = "0"b;		/* reset this flg after the request is done. */

RETURNED:
	return;

/***************************************************************************/
%page;
rewind_request: entry (sci_ptr, rtq_info_ptr);

/* Establish cleanup and program_interrupt handlers.  Display an usage     */
/* message if any control argument is given.  Perform the "rewind" control */
/* order by invoking the "process_control_order" internal procedure.       */
/* Return to the subsystem request loop.                                   */

/* begin coding */
	on cleanup call detach_tape_file (sci_ptr, rtq_info_ptr);

	on program_interrupt goto PI_RETURN;

	call ssu_$arg_count (sci_ptr, Nargs);
	if Nargs ^= 0 then do;
		call ssu_$print_message (sci_ptr, 0, "Usage:  rewind (rew)");
		return;
	     end;

/* initialization */
	scode = 0;
	l_cnt = 1;				/* 1 iteration default */
	rpt, rf, direction = "0"b;			/* reset command flags */
	order = "rewind";

	call process_control_order (order, rpt, direction, rf, l_cnt); /* go process control order */

/* must reset the following flags if they were previously set */
	rtq_info.eof, rtq_info.eov, rtq_info.one_eof, rtq_info.two_eofs = "0"b;

PI_RETURN:
	return;

/****************************************************************************/
%page;
ANSI_DB_records: proc (conversion_flg);

/* process each ANSI DB record of the input tape file for the "rdfile" request */

	dcl     conversion_flg	 bit (*) aligned;

/* begin coding */
	nchars = 0;
	rtq_info.rptr = rtq_info.tptr;		/* set first log record ptr */

	on conversion begin;
		call ssu_$print_message (sci_ptr, 0,
		     "Conversion condition detected attempting to convert ANSI log rec len (""^a"") to binary",
		     ansi_db_lrec.lrl);

		conversion_flg = "1"b;
		goto BACK_TO_RTQ_REQUEST_LOOP;	/* return to rtq subsystem request loop */
	     end;

	do while (nchars < rtq_info.rec_len - 3);	/* process entire block */
	     l_rec_len = bin (ansi_db_lrec.lrl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */

	     if l_rec_len = 0 then do;		/* if null record, write empty line */
		     call write_file (addr (NL), 1, s_filename);

		     if rtq_info.return_subsys_loop_flg then return;
		end;
	     else do;				/* record contains data */
		     if c_e_a then /* if ebcdic record */
			call ebcdic_to_ascii_ (ansi_db_lrec.alrd, rtq_info.cbufp -> cbuf);
		     else rtq_info.cbufp -> cbuf = ansi_db_lrec.alrd; /* otherwise, copy it */

		     trim_trailing_blanks_log_rec_len = length (rtrim (rtq_info.cbufp -> cbuf));

		     if ^nnl_sw then do;		/* add New Line character to each record */
			     trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
			     substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
			end;

		     call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */

		     if rtq_info.return_subsys_loop_flg then return;
		end;				/* record contains data */

	     rtq_info.rptr = addr (ansi_db_lrec.nxt_lrec);
	     nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total # of chars */

	end;					/* do while ... */

BACK_TO_RTQ_REQUEST_LOOP:
	return;

     end ANSI_DB_records;

/****************************************************************************/
%page;
CP5_variable_length_records: proc ();

/* process each logical record of the input tape file in the CP5 standard   */
/* system format for the read_file request.                                 */

/* begin coding */
	rtq_info.rptr = addr (cp5_phy_rec.first);	/* get ptr to first record */

	do i = 1 to cp5_phy_rec.nky;
	     call ebcdic_to_ascii_ (cp5_log_rec.cp5_log_rec_data, rtq_info.cbufp -> cbuf);

	     substr (rtq_info.cbufp -> cbuf, cp5_log_rec.rlen + 1, 1) = NL; /* add new line char to end */

	     call write_file (rtq_info.cbufp, cp5_log_rec.rlen + 1, s_filename); /* write out this logical record */

	     if rtq_info.return_subsys_loop_flg then
		return;

	     rtq_info.rptr = addrel (rtq_info.rptr, currentsize (cp5_log_rec)); /* go to next one */
	end;

	return;

     end CP5_variable_length_records;

/****************************************************************************/
%page;
DEC_tape_records: proc ();

/* process each record of the input tape file in DEC standard system format */
/* for the read_file request.                                               */

	dcl     DEC_40_bits_per_word	 fixed bin static options (constant) init (40);

/* convert DEC to MULTICS standard words */
	it_cnt = divide (rtq_info.bits, DEC_40_bits_per_word, 17, 0); /* get number of 40 bit words  */

	do i = 1 to it_cnt;				/* each record is 512 40 bit words */
	     dec_mult (i).first_32 = dec_tape_raw.ps_wd (i).first_32; /* copy 1st 32 bits */

	     dec_mult (i).last_4 = dec_tape_raw.ps_wd (i).last_4; /* copy last 4 bits */
	end;

	call write_file (lrp, it_cnt * 4, s_filename);	/* write out this record */

	return;

     end DEC_tape_records;

/****************************************************************************/
%page;
IBM_VB_records: proc ();

/* process each IBM VB_formated variable_length record of the input tape   */
/* file for the "rdfile" request.                                          */

/* begin coding */
	nchars = 0;
	blocksize = bin (bdw.msl || bdw.lsl) - NUMB_OF_CHARS_PER_WORD;
	rtq_info.rptr = addr (ibm_phy_rec.iprd);	/* set first logical record ptr */

	do while (nchars < blocksize);		/* process entire block */
	     l_rec_len = bin (rdw.msl || rdw.lsl) - NUMB_OF_CHARS_PER_WORD; /* compute logical record size */

	     if c_e_a then /* if ebcdic record */
		call ebcdic_to_ascii_ (ibm_log_rec.ilrd, rtq_info.cbufp -> cbuf);
	     else rtq_info.cbufp -> cbuf = ibm_log_rec.ilrd; /* otherwise, copy it */

	     trim_trailing_blanks_log_rec_len = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rtq_info.rec_len)));

	     if ^nnl_sw then do;			/* add new line character to each record */
		     trim_trailing_blanks_log_rec_len = trim_trailing_blanks_log_rec_len + 1;
		     substr (rtq_info.cbufp -> cbuf, trim_trailing_blanks_log_rec_len, 1) = NL;
		end;

	     call write_file (rtq_info.cbufp, trim_trailing_blanks_log_rec_len, s_filename); /* write out log record */

	     if rtq_info.return_subsys_loop_flg then
		return;

	     rtq_info.rptr = addr (ibm_log_rec.nxt_lrec);
	     nchars = nchars + l_rec_len + NUMB_OF_CHARS_PER_WORD; /* increment total  # of chars */
	end;

	return;

     end IBM_VB_records;

/****************************************************************************/
%page;
GCOS_ssf: proc (cont, imcv, nchars, binck, first_record_flg, s_filename);

/* process GCOS standard system format records.                           */

	dcl     binck		 bit (1) aligned;
	dcl     card_cnt		 fixed bin;
	dcl     cont		 bit (1) aligned;
	dcl     dkend_card		 bit (1) aligned;
	dcl     eoc		 bit (1) aligned;
	dcl     (fc, fl)		 bit (1) aligned;
	dcl     first_record_flg	 bit (1) aligned;
	dcl     gcos_trans		 (9) char (6) static options (constant) init
				 ("gmap  ", "355map", "355sim", "algol ", "forta ", "forty ", "cobol ", "cob68 ", "jovial");
	dcl     imcv		 bit (1) aligned;
	dcl     nchars		 fixed bin (21);	/* will reference in get_file_name procedure */
	dcl     obj_card		 bit (1) aligned;
	dcl     p_arg		 char (168) varying init ("");
	dcl     s_filename		 char (32) var;	/* save for calling write_file procedure */

/* based */
	dcl     1 comdk		 aligned based (rtq_info.cdptr), /* structure of a comdeck card */
	        ( 2 type		 bit (12),	/* bin card type, "5005"b3 for comdeck */
		2 bin_seq		 bit (24),	/* binary sequence number */
		2 ckeck_sum	 bit (36),	/* check sum word */
		2 data		 bit (21 * 36),	/* 21 data words */
		2 h_seq		 (4) bit (12),	/* holorith seq number */
		2 pad		 bit (12)) unaligned;

	dcl     1 com_fld		 unaligned based (rtq_info.cfptr), /* template for compression */
		2 f_len		 bit (6),		/* field length */
		2 s_len		 bit (6),		/* string length */
		2 bcd_str		 bit (fixed (com_fld.s_len, 6) * 6), /* bcd char string */
		2 nxt		 bit (6),		/* field or card fence */
		2 nxt_fld		 bit (6);		/* to get to next field */

/* begin coding */
	if ^first_record_flg then do;			/* if first record of file */
		bcnt = gc_phy_rec.bcw.bsn;		/* load block serial number */
		first_record_flg = "1"b;
	     end;
	else do;					/* if not first record, check block serial number */
		bcnt = bcnt + 1;			/* increment our block count */
		if gc_phy_rec.bcw.bsn ^= bcnt then do;	/* something wrong here */
			call ssu_$print_message (sci_ptr, 0,
			     "Block serial number error; BSN was ^d, S/B ^d", gc_phy_rec.bcw.bsn, bcnt);

			YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");

			if YES_FLG then do;		/* users want to stop */
				call detach_file_if_attached; /* just in case we had a file attached */

				rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */

				return;
			     end;
			else bcnt = gc_phy_rec.bcw.bsn; /* reset block number */
		     end;				/* something wrong */
	     end;					/* not first record */

	if gc_phy_rec.bcw.blk_size > rtq_info.wd_buf_size then do; /* is our buffer big enough? */
		call ssu_$print_message (sci_ptr, 0, "Phyical record size (^d) is larger than buffer size (^d)",
		     gc_phy_rec.bcw.blk_size, rtq_info.wd_buf_size);

		YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");

		if YES_FLG then do;			/* users want to stop */
			call detach_file_if_attached; /* just in case we had a file attached */

			rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */

			return;
		     end;
	     end;					/* our buffer is big enough */

	lrptr = addr (gc_phy_rec.gc_phy_rec_data (1));	/* get pointer to first logical record */
	nwds = 0;					/* initialize number of words */
	card_cnt = 1;				/* set initial card count for this block */
	obj_card, dkend_card = "0"b;			/* clear bin card indicators */

	do while (nwds < gc_phy_rec.bcw.blk_size);	/* iterate through all logical records */
	     if ^cont then rtq_info.cbufp -> cbuf = "";
	     go to media_type (rcw.media_code);		/* take appropriate action */
%page;
/* media code 1 is binary card image */

media_type (1):					/* Binary card image */
	     rtq_info.cdptr = addr (gc_log_rec.gc_log_rec_data); /* set ptr to data */
	     if comdk.type = "5005"b3 then do;		/* compressed deck? */
		     rtq_info.cfptr = addr (comdk.data);/* lets decompress it */
		     fc = "0"b;			/* reset terminate condition */

		     do while (^fc);		/* go through entire card */
			if ^cont then do;		/* not continuing from last card */
				nchars = 1;	/* set line position to 1 */
				rtq_info.cbufp -> cbuf = ""; /* add blanks to line buffer */
			     end;

			fl = "0"b;
			do while (^fl & ^fc);	/* decompress each line */
			     i = fixed (f_len, 6);	/* get field length */
			     j = fixed (s_len, 6);	/* get string length */

			     if f_len = "77"b3 then do; /* end of line */
				     cont = "0"b;	/* reset continue */
				     fl = "1"b;
				     rtq_info.cfptr = addr (com_fld.s_len); /* skip over it */
				end;		/* end of line */

			     else if i < j | (i = 0 & j = 0) then do; /* end of card */
				     eoc, fc = "1"b;
				     cont = "0"b;	/* turn off continue flag */
				end;		/* end of card */

			     else do;
				     eoc = "0"b;
				     if j ^= 0 then do;
					     rtq_info.cdkp -> cdkbuf = "";
					     call bcd_to_ascii_ (bcd_str, rtq_info.cdkp -> cdkbuf); /* convert  string to ascii */
					     substr (rtq_info.cbufp -> cbuf, nchars + (i - j), j) = rtq_info.cdkp -> cdkbuf; /* set string in position */
					end;	/* not end of line and not end of card */

				     nchars = nchars + i; /* update line position */

				     if com_fld.nxt = "76"b3 then do; /* end of compressed deck */
					     fc = "1"b;
					     cont = "0"b; /* turn off continue so we will write this line */
					end;	/* end of compressed deck */

				     else if com_fld.nxt = "77"b3 then do; /* end of this line */
					     fl = "1"b; /* set terminate condition */
					     cont = "0"b; /* not a continued line */
					     rtq_info.cfptr = addr (com_fld.nxt_fld); /* set ptr to skip line fence */
					end;	/* end of this line */

				     else if com_fld.nxt = "00"b3 then /* line continued in next card */
					cont, fc = "1"b;

				     else rtq_info.cfptr = addr (com_fld.nxt); /* otherwise just go to nxt field */
				end;		/* not end of line and not end of card */
			end;			/* do while ^fl &^fc */

			if ^cont & ^eoc then do;	/* line continues on next card */
				substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* add new line to end of line */
				call write_file (rtq_info.cbufp, nchars, s_filename); /* write out the line */
			     end;			/* if line continues on next card */
		     end;				/* do while not end of card */
		end;				/* compressed deck */
	     else do;				/* user wants copy */

ck_obj:
		     if obj_card then do;		/* we have passed a $ object card */
			     obj_card = "0"b;
			     if card_cnt ^= 2 then do;/* not first card of blk */
				     call ssu_$print_message (sci_ptr, 0, "$ object card not first card of blk");
				     rtq_info.return_subsys_loop_flg = "1"b;
				     return;	/* return to subsystem */
				end;

/* nchars = current card size + prev card size + bcw */
			     nchars = (rtq_info.cvp -> rcw.rsize + rcw.rsize + 3) * NUMB_OF_CHARS_PER_WORD;
			     rtq_info.cvp = addrel (rtq_info.cvp, -1); /* don't forget bcw */
			end;			/* if we have passed a $ object card */

		     else if card_cnt = 1 then do;	/* include only bcw */
			     nchars = (rcw.rsize + 2) * NUMB_OF_CHARS_PER_WORD;
			     rtq_info.cvp = addrel (lrptr, -1);
			end;

		     else do;			/* include just this card */
			     nchars = (rcw.rsize + 1) * NUMB_OF_CHARS_PER_WORD;
			     rtq_info.cvp = lrptr;
			end;

		     call write_file (rtq_info.cvp, nchars, s_filename);

		     if dkend_card then do;		/* if last card of deck */
			     dkend_card = "0"b;

			     call detach_file_if_attached; /* just in case we had a file attached */
			end;			/* last card of deck */
		end;				/* user wants copy */

	     go to gssf_end;
%page;
/* media codes 0, 2, 3, and 9 - bcd records */

media_type (0):					/* Not a media conversion record */
media_type (2):					/* BCD card image */
media_type (3):					/* BCD print line image */
media_type (9):					/* Bcd print line image (with user defined rpt code) */

	     call bcd_to_ascii_ (gc_log_rec_bits, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */
	     rtq_info.cbufp -> cbuf = translate (rtq_info.cbufp -> cbuf, "='+)(", "#@&]%"); /* take care of stange conversion chars */
	     if rcw.media_code = 2 then do;		/* if bcd card */
		     nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, 80))) + 1; /* set max length to 80 char */
		     if substr (rtq_info.cbufp -> cbuf, 1, 13) = "$      object" then do; /* and object card */
			     obj_card = "1"b;
			     rtq_info.cvp = addrel (lrptr, currentsize (gc_log_rec)); /* look at nxt card */
			     if rtq_info.cvp -> rcw.media_code = 1 then do; /* if binary card */
				     binck = "1"b;	/* set flag so we don't come back */
				     call detach_file_if_attached; /* this should not happen but ... */

				     call get_file_name ("obj", nchars); /* get filename */
				     if rtq_info.return_subsys_loop_flg then
					return;	/* return to subsystem */

				     go to gssf_end;/* card will be written with next one */
				end;		/* binary card */
			end;			/* object card */

		     else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$      dkend" then /* dkend card */
			if binck then do;		/* process only if we have been doing something with  bin cards */
				if substr (rtq_info.cbufp -> cbuf, 16, 8) ^= "continue" then /* if continue card keep on going */
				     dkend_card = "1"b;
				go to ck_obj;	/* copy this one too */
			     end;
			else ;

		     else if substr (rtq_info.cbufp -> cbuf, 1, 12) = "$      snumb" then do; /* snumb card */
			     i = search (substr (rtq_info.cbufp -> cbuf, 16, 6), ","); /* if any commas, find out */
			     if i = 0 then /* no commas, use name as is */
				p_arg = substr (rtq_info.cbufp -> cbuf, 16, 6); /* generate filename */
			     else p_arg = substr (rtq_info.cbufp -> cbuf, 16, i - 1); /* don't like commas in seg names */

			     if ^valid_pathname ((p_arg), "imcv") then do;
				     rtq_info.return_subsys_loop_flg = "1"b;
				     return;	/* return to subsystem */
				end;

			     call detach_file_if_attached; /* detach old file, if attached */

			     imcv = "1"b;		/* set indicator switch */
			     rtq_info.fw_file, cont = "0"b; /* reset so file name will appear on terminal */
			end;			/* snumb card */

		     else if ^imcv then do;		/* a $ language card */
			     rtq_info.tmr = "0"b;	/* reset terminate condition */
			     do i = 1 to hbound (gcos_trans, 1) while (^rtq_info.tmr);
				if substr (rtq_info.cbufp -> cbuf, 8, 6) = gcos_trans (i) then rtq_info.tmr = "1"b;
			     end;
			     if rtq_info.tmr then do; /* found a valid language card */
				     if rtq_info.f_attached then do; /* if we had a file attached before... */
					     call write_file (addr (eoj_card), length (eoj_card), s_filename); /* complete jcl */

					     if rtq_info.return_subsys_loop_flg then
						return;

					     call detach_file_if_attached;
					end;

				     call get_file_name ("ascii", nchars); /* get filename */

				     if rtq_info.return_subsys_loop_flg then
					return;

				     rtq_info.last_job_deck_flg = "1"b; /* set flag for last job deck */
				     call ioa_$rsnnl ("$      snumb   ^a^/$      ident^/^a^/$      limits  8,64k,,50000^/",
					rtq_info.cbufp -> cbuf, rtq_info.clen, substr (rtq_info.filename, 1, 3),
					substr (rtq_info.cbufp -> cbuf, 1, nchars));

				     call write_file (rtq_info.cbufp, rtq_info.clen, s_filename); /* write out jcl */

				     cont = "0"b;	/* reset continue flag */

				     if rtq_info.return_subsys_loop_flg then
					return;

				     go to gssf_end;
				end;		/* a valid language card */
			end;			/* a $ language card */
		end;				/*  a bcd card */

	     else if rcw.media_code = 9 then do;	/* if user rpt code present */
		     rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */
		     nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) - 2; /* get length of string */
		end;				/* user rpt code */

	     else nchars = length (rtrim (substr (rtq_info.cbufp -> cbuf, 1, rcw.rsize * 6))) + 1; /* get length of string */

	     substr (rtq_info.cbufp -> cbuf, nchars, 1) = NL; /* append new line to end of string */

	     call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */

	     if rtq_info.return_subsys_loop_flg then
		return;

	     go to gssf_end;
%page;
/* media codes 6, 7, 10, and 13 are ascii records */

media_type (6):					/* ssf ascii */
media_type (7):					/* Ascii print line image */
media_type (10):					/* Ascii card image */
media_type (13):					/* Ascii print line image (with user defined rpt code) */

	     rtq_info.cvp = addr (gc_log_rec.gc_log_rec_data);
	     if rcw.nchar_used ^= 0 then /* if we have a partial word */
		nchars = ((rcw.rsize - 1) * NUMB_OF_CHARS_PER_WORD) + rcw.nchar_used + 1;
	     else nchars = rcw.rsize * NUMB_OF_CHARS_PER_WORD + 1;

	     rtq_info.cbufp -> cbuf = substr (gssf_ascii, 1, nchars - 1) || NL;
	     if rcw.media_code = 13 then do;		/* if user rpt code present */
		     rtq_info.cbufp -> cbuf = substr (rtq_info.cbufp -> cbuf, 3); /* wipe it out */
		     nchars = nchars - 2;
		end;

	     call write_file (rtq_info.cbufp, nchars, s_filename); /* write out this logical record */

	     if rtq_info.return_subsys_loop_flg then
		return;				/* return to subsystem */

	     go to gssf_end;


/* media codes 4, 5, 11, 12, 14, and 15 are illegal media codes */

media_type (4):					/* Reserved for user */
media_type (5):					/* Tss ascii (before release E) */
media_type (11):					/* Illegal media code */
media_type (12):					/* Illegal media code */
media_type (14):					/* Illegal media code */
media_type (15):					/* Illegal media code */

	     call ssu_$print_message (sci_ptr, 0, "Illegal media code ^o detected in card number ^d of block ^d",
		rcw.media_code, card_cnt, bcnt);
	     rtq_info.return_subsys_loop_flg = "1"b;
	     return;				/* this is not a gcos deck, return */


media_type (8):					/* tss info record, ignore */

gssf_end:
	     nwds = nwds + rcw.rsize + 1;		/* increment number of words */
	     rtq_info.cvp = lrptr;			/* save ptr to current logical record */
	     lrptr = addrel (lrptr, currentsize (gc_log_rec)); /* set next logical record */
	     card_cnt = card_cnt + 1;			/* increment card count */

	end;					/* do while nwds < gc_phy_rec.bcw.blk_size */

     end GCOS_ssf;

/****************************************************************************/
%page;
MULT_ssf: proc (first_record_flg, last_record_flg, s_filename);

/* process MULTICS standard system format records.                           */

	dcl     first_record_flg	 bit (1) aligned;
	dcl     last_record_flg	 bit (1) aligned;
	dcl     s_filename		 char (32) varying; /* save for calling write_file procedure */

	dcl     1 mult_buf		 based (rtq_info.tptr) aligned, /* buffer for MULTICS standard tape record */
		2 cur_rec		 (1040) bit (36),	/* storage for current record */
		2 last_rec	 char (rtq_info.clen); /* storage for last record read */

/* begin coding */
	mstrp = rtq_info.tptr;			/* set Multics standard record ptr */

	if ^first_record_flg then do;			/* if this is the first rcd set flag */
		first_record_flg = "1"b;
		bcnt = mstr.head.rec_within_file;	/* set initial record number within file */
	     end;

	else if ^mstr.head.flags.repeat then do;	/* if not repeat record */
		bcnt = bcnt + 1;			/* increment record counter */
		if bcnt ^= mstr.head.rec_within_file & ^last_record_flg then do; /* sequence error */
			call ssu_$print_message (sci_ptr, 0,
			     "Record sequence number error; Record sequence number was ^d; S/B ^d",
			     mstr.head.rec_within_file, bcnt);

			YES_FLG = command_query_yes_no ("Do you want to stop and return to the rtq request loop?  Answer ""yes"" or ""no"".", "Stop?");

			if YES_FLG then do;		/* users want to stop */
				call detach_file_if_attached; /* just in case we had a file attached */

				rtq_info.return_subsys_loop_flg = "1"b; /* users want to return to subsystem request loop */

				return;
			     end;
			else bcnt = mstr.head.rec_within_file; /* reset block number */
		     end;				/* sequential error */

		call write_file (addr (mult_buf.last_rec), rtq_info.clen, s_filename); /* write out last record */

		if rtq_info.return_subsys_loop_flg then return;

	     end;					/* not repeat record */

	if ^last_record_flg then do;			/* if current record is not eof */
		rtq_info.clen = divide (mstr.head.data_bits_used, 9, 17, 0); /* get char length */
		addr (mult_buf.last_rec) -> mult_move = addr (mstr.data) -> mult_move; /* move it */
	     end;

     end MULT_ssf;

/****************************************************************************/
%page;
attach_and_open_output_file: proc;

/* attach file */
RETRY:
	call iox_$attach_name ("file_sw", rtq_info.fiocb_ptr, att_desc, null, scode);
	if scode ^= 0 then do;

		if scode = error_table_$not_detached then do;
			call iox_$detach_iocb (rtq_info.fiocb_ptr, scode);
			if scode ^= error_table_$not_closed then
			     goto ERR_ATTACHED;
			else do;
				call iox_$close (rtq_info.fiocb_ptr, scode);
				goto RETRY;
			     end;
		     end;
		else do;				/* display error messages */

ERR_ATTACHED:
			call ssu_$print_message (sci_ptr, scode,
			     "^/     Attempting to attach file.^/     Attach description: ^a", att_desc);

			rtq_info.return_subsys_loop_flg = "1"b;
			return;
		     end;
	     end;					/* scode ^= 0 */

	rtq_info.f_attached = "1"b;			/* set attached switch */

/*  open file */
	call iox_$open (rtq_info.fiocb_ptr, open_mode, "0"b, scode);

	if scode ^= 0 then do;
		call ssu_$print_message (sci_ptr, scode,
		     "^/     Opening ^a for ^a", att_desc, iox_modes (open_mode));

		call detach_file_if_attached;		/* just in case we had a file attached */

		rtq_info.return_subsys_loop_flg = "1"b;
		return;
	     end;


     end attach_and_open_output_file;

/****************************************************************************/
%page;
check_mode: proc (a_mode);

/* check and set tape dim in a specified reading mode.                      */

	dcl     a_mode		 fixed bin;

/* set desired mode if required and tell user what we have done */
	if rtq_info.c_mode ^= a_mode then do;
		rtq_info.c_mode = a_mode;

		call ioa_ ("Setting tape dim to read in ^a mode", mode (rtq_info.c_mode));

		call process_control_order (mode (rtq_info.c_mode), "0"b, "0"b, "0"b, 1);
	     end;

     end check_mode;

/**************************************************************************/
%page;
command_query_no_entrypoint:  proc (explain_to_users, ask_users_question) returns (char (200) varying);


	dcl     ask_users_question	 char (*);
	dcl     explain_to_users	 char (*);
	dcl     get_users_answer	 char (64);

/* external entry */
	dcl     command_query_	 entry options (variable);

%page;
%include query_info;
%page;
/* begin coding */
	who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);

	unspec (query_info) = "0"b;			/* clear out query_info structure */

	query_info.version = query_info_version_6;
	query_info.prompt_after_explanation = "1"b;
	query_info.question_iocbp, query_info.answer_iocbp = null;
	query_info.explanation_ptr = addr (explain_to_users);
	query_info.explanation_len = length (explain_to_users);

	call command_query_ (addr (query_info), get_users_answer, (who_asked), ask_users_question);

	return (rtrim (get_users_answer));

     end command_query_no_entrypoint;

/**************************************************************************/
%page;
command_query_yes_no: proc (interpretation_string, query_string) returns (bit (1) aligned);

/* ask users for a yes or no answer.                                      */

	dcl     A_YES_OR_NO_ANSWER	 bit (1) aligned;
	dcl     interpretation_string	 char (95);
	dcl     query_string	 char (28);

/* external entry */
	dcl     command_query_$yes_no	 entry options (variable);

/* begin coding */
	A_YES_OR_NO_ANSWER = "0"b;

	who_asked = ssu_$get_subsystem_and_request_name (sci_ptr);

	call command_query_$yes_no (A_YES_OR_NO_ANSWER, 0, (who_asked), interpretation_string, query_string);

	return (A_YES_OR_NO_ANSWER);

     end command_query_yes_no;

/**************************************************************************/
%page;
detach_file_if_attached: proc ();

/* detach an old file if it was already attached.                         */

/* begin coding */
	if rtq_info.f_attached then do;
		call iox_$close (rtq_info.fiocb_ptr, (0));
		call iox_$detach_iocb (rtq_info.fiocb_ptr, (0));
		rtq_info.last_job_deck_flg, rtq_info.f_attached = "0"b;
	     end;

     end detach_file_if_attached;

/***************************************************************************/
%page;
detach_tape_file: proc (sci_ptr, rtq_info_ptr);

/* detach and close tape and file.                                         */

	dcl     release_area_	 entry (ptr);
	dcl     release_temp_segment_	 entry (char (*), ptr, fixed bin (35));
	dcl     (rtq_info_ptr, sci_ptr) ptr;

/* close and detach  tape switch which was attached and opened earlier */
	if rtq_info.tiocb_ptr ^= null then do;
		call iox_$close (rtq_info.tiocb_ptr, (0));
		call iox_$detach_iocb (rtq_info.tiocb_ptr, (0));
		rtq_info.tiocb_ptr = null;
	     end;

/* release temp segment if already allocated */
	if rtq_info.tptr ^= null then
	     call release_temp_segment_ (pname, rtq_info.tptr, (0)); /* release our tape buffer */

/* release an area which already assigned */
	if rtq_info.rtq_area_ptr ^= null then do;
		call release_area_ (rtq_info.rtq_area_ptr);
		ai.areap = null;
	     end;

/* if file was attached then detach it */
	call detach_file_if_attached;

	return;

     end detach_tape_file;

/**************************************************************************/
%page;
determine_tape_label_types: proc ();

/* determine the tape label type and then process the specified tape type */
/* (e.g. MULTICS, GCOS, IBM, ANSI)                                        */

/* begin code */
	if rtq_info.tptr -> mult.lab_id = header_c1 then do; /* Multics standard tape */
		rcd_volid = rtq_info.tptr -> mult.tape_reel_id; /* copy volume id directly */
		rtq_info.l_type = v1_mult_label;
	     end;					/* MULTICS standard tape */

	else if rtq_info.tptr -> mult.lab_id = label_c1 then do; /* is this a bootable MST? */

		if (rtq_info.tptr -> mst_label.head.c1 = header_c1) & (rtq_info.tptr -> mst_label.head.label) then do;
			rcd_volid = rtq_info.tptr -> mst_label.tape_reel_id; /* copy volume id directly */
			rtq_info.l_type = v3_mult_label;
		     end;
	     end;

	else if rtq_info.tptr -> gcos.lab_id = g_label then do; /* GCOS standard tape */
		call bcd_to_ascii_ (rtq_info.tptr -> gcos.vol_id, rcd_volid); /* convert bcd */
		rtq_info.l_type = 3;		/* gcos_label value */
	     end;					/* GCOS standard tape */

	else if rtq_info.tptr -> ibm_ansi.lab_id = i_label then do; /* IBM standard tape */
		call ebcdic8_to_ascii_ (rtq_info.tptr -> ibm_ansi.vol_id, rcd_volid); /* convert packed ebcdic to ascii */
		rtq_info.l_type = ibm_label;
	     end;					/* IBM standard tape */

	else if rtq_info.tptr -> ibm_ansi.lab_id = a_label then do; /* ANSI standard tape */
		do i = 0 to 5;			/* unpack 8bit ascii to 9bit ascii */
		     blab (i) = "0"b || substr (rtq_info.tptr -> ibm_ansi.vol_id, (i * 8) + 1, 8);
		end;
		rtq_info.l_type = ansi_label;
	     end;					/* ANSI standard tape */

	else if rtq_info.tptr -> cp5_lab.lab_id = CP5_label then do; /* cp5 stand tape */
		call ebcdic8_to_ascii_ (rtq_info.tptr -> cp5_lab.vol_id, rcd_volid); /* convert tape name */
		rtq_info.l_type = cp5_label;
	     end;					/* CP5 standard tape */

	else do;					/* unlabeled tape */
		call ioa_ ("Tape ^a is ^a or has unrecognized label.^/Tape will remain positioned at BOT.",
		     rtq_info.tape_name, LABEL (rtq_info.l_type));

		return;
	     end;

	call ioa_ ("Tape ^a is a labeled ^a tape.^/Volume name recorded on tape label is ^a.",
	     rtq_info.tape_name, LABEL (rtq_info.l_type), rcd_volid);

	if rtq_info.l_type = ibm_label | rtq_info.l_type = ansi_label then do; /* if IBM or ANSI tape */
		call check_mode (NINE_MODE);		/* set reading mode to nine */

		call process_control_order ("forward_record", "1"b, "1"b, "0"b, 2); /* space to HDR2 record */

		call read_tape_record ("stop", rtq_info.eof, "0"b, mssf); /* and read it in */

		if rtq_info.return_subsys_loop_flg then
		     return;

		if ^rtq_info.eof then do;		/* if no error */

			call ioa_ ("First data file format:");

			if ^valid_label_record ("0"b) then /* if hdr2 rcd does not exist */

			     call ssu_$print_message (sci_ptr, 0, "Could not find ^a HDR2 record.", LABEL (rtq_info.l_type));
		     end;				/* if ^eof  */
		else do;				/* error reading hdr2 record */
			call ssu_$print_message (sci_ptr, 0, "Error reading HDR2 record, tape will be rewound to BOT");

			call process_control_order ("rewind", "0"b, "0"b, "0"b, 1);

			return;
		     end;				/* else do */
	     end;					/* if l_type = ibm_label | l_type = ansi_label */

	call ioa_ ("Positioning to beginning of physical tape file # 2, (logical file # 1)");

	call process_control_order ("forward_file", "1"b, "1"b, "1"b, 1);

	return;

     end determine_tape_label_types;

/***************************************************************************/
%page;
get_file_name: proc (dtype, nchars);

/* get file name from gcos card or query user.                             */

	dcl     dtype		 char (5);
	dcl     nchars		 fixed bin (21);
	dcl     output_filename	 char (168) aligned;

/* begin coding */
	if nchars >= 73 then /* if full card */
	     if substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "" |
		substr (rtq_info.cbufp -> cbuf, 73, 4) ^= "0000" then do; /* and not garbage */
		     rtq_info.filename = rtrim (substr (rtq_info.cbufp -> cbuf, 73, 4)); /* extract name */
		     i = index (rtq_info.filename, NL); /* check for imbedded newline */
		     if i ^= 0 then /* remove it if so */
			substr (rtq_info.filename, i) = substr (rtq_info.filename, i + 1);
		end;
	     else ;
	else do;					/* name not on card, query user */
		call ioa_ ("^a", substr (rtq_info.cbufp -> cbuf, 1, 80)); /* display card image for user */

		rtq_info.tmr = "0"b;		/* initialize terminate condition */
		output_filename = "";
		do while (^rtq_info.tmr);		/* if no filename */
		     output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Ouput file name:  ");

		     rtq_info.tmr = valid_pathname ((output_filename), "");
		     if ^rtq_info.tmr then
			goto PATHNAME_ERROR;
		end;				/* do while ^rtq_info.tmr */
	     end;					/* else do */

	if ^valid_pathname ((rtq_info.filename), dtype) then do;

PATHNAME_ERROR:
		call ssu_$print_message (sci_ptr, scode, "Expanding pathname for file name ""^a""", rtq_info.filename);
		rtq_info.return_subsys_loop_flg = "1"b;
		return;				/* return subsystem */
	     end;

	rtq_info.fw_file = "0"b;			/* reset switch so we get message */

     end get_file_name;

/***************************************************************************/
%page;
get_output_descript_and_attach: proc ();

/* query users for the output attach description and an opening mode       */
/* before invoke "attach_and_open_output_file" internal procedure.         */

/* if file not attached already */
	if ^rtq_info.f_attached then do;

		attach_desc_output = command_query_no_entrypoint ("Please enter an output attach description.", "Output attach description:  ");

		att_desc = attach_desc_output;	/* copy attach description */

		attach_desc_output = command_query_no_entrypoint ("Please enter an opening mode.", "Opening mode:  ");

/* loop throught two given arrays of modes to find a matched mode */
		do i = 1 to hbound (iox_modes, 1)
		     while (attach_desc_output ^= iox_modes (i) & attach_desc_output ^= short_iox_modes (i));
		end;

		if i > hbound (iox_modes, 1) then do;	/* invalid mode specification */
			call ssu_$print_message (sci_ptr, 0, "Invalid opening mode specification ""^a""", attach_desc_output);

			rtq_info.return_subsys_loop_flg = "1"b;
			return;
		     end;

/* set opening mode to user's specified mode */
		open_mode = i;

/* attach file now to make sure i/o module exists */
		call attach_and_open_output_file;
	     end;					/* if ^rtq_info.f_attached */

	return;

     end get_output_descript_and_attach;

/***************************************************************************/
%page;
get_tape_status: proc;

/* get octal and English description of tape error.                        */

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

/* begin coding */
	status_story = "";				/* clear old description first */
	call iox_$control (rtq_info.tiocb_ptr, "saved_status", addr (t_stat), scode);

	call analyze_device_stat_$rsnnl (status_story, addr (tape_status_table_$tape_status_table_), (t_stat), ("0"b));

     end get_tape_status;

/****************************************************************************/
%page;
process_control_order: proc (a_order, a_rpt, a_dir, a_rf, a_cnt);

/* process control orders (non-data xfer tape commands)                     */

	dcl     a_cnt		 fixed bin (35);
	dcl     a_dir		 bit (1) aligned;
	dcl     a_order		 char (*);
	dcl     a_rf		 bit (1) aligned;
	dcl     a_rpt		 bit (1) aligned;
	dcl     backspace_file_flg	 bit (1) aligned init ("0"b);
	dcl     count		 fixed bin (35);
	dcl     i			 fixed bin (35);
	dcl     order		 char (16);

/* begin coding */
	order = a_order;				/* copy control order */
	count = a_cnt;				/* copy count arg */
	backspace_file_flg = "0"b;			/* reset backspace file flag if set */

	if a_rpt then do;				/* if space cmd */
		if ^a_dir then do;			/* backspace cmd */
			if a_rf then do;		/* file cmd */
				if rtq_info.c_file - count < 1 then do; /* can't backspace that far */

					call ioa_ ("Tape will be positioned at BOT");

					call process_control_order ("rewind", "0"b, "0"b, "0"b, 1); /* call ourselves recursively */
					return;
				     end;
				else do;		/* backspace file, or begin file */
					rtq_info.c_rec = 1; /* deterimine the first record in the file */

					if order = "begin_file" then do; /* if begin file operation */
						order = "backspace_file";
						backspace_file_flg = "1"b; /* set backspace file flag */
					     end;
					else do;	/* a real backspace file */
						/* decrement file number to "count" time(s) and go back count + 1 files */
						rtq_info.c_file = rtq_info.c_file - count;

						if rtq_info.c_file > 1 then
						     backspace_file_flg = "1"b;

						count = count + 1; /* really going back n + 1 files */
					     end; /* else do */
				     end;		/* else do */
			     end;			/* a_rf */
			else if rtq_info.c_rec - count < 1 then do; /* record cmd */
				call ioa_ ("Tape will be positioned at beginning of file ^d", rtq_info.c_file);

				call process_control_order ("begin_file", "1"b, "0"b, "1"b, 1); /* call ourselves recursively */
				return;
			     end;			/* else if c_rec - count < 1 */
			else rtq_info.c_rec = rtq_info.c_rec - count; /* bsr ok, reset position */

		     end;				/* ^a_dir */
		else do;				/* a_dir  means a forward space cmd */
			if a_rf then do;		/* file cmd */
				rtq_info.c_rec = 1; /* reset position counters */
				rtq_info.c_file = rtq_info.c_file + count;
			     end;
			else if ^rtq_info.eof_request_flg then
			     rtq_info.c_rec = rtq_info.c_rec + count; /* fsr cmd */
		     end;				/* else do */
	     end;					/* if a_rpt  means a space cmd */

	if order = "rewind" then /* if order is rewind */
	     rtq_info.c_rec, rtq_info.c_file = 1;	/* reset position */

	do i = 1 to count;				/* iterate control order requested times */
	     call iox_$control (rtq_info.tiocb_ptr, order, null, scode);

	     if scode ^= 0 then do;
		     if scode = error_table_$end_of_info & rtq_info.records_in_file_flg then do;
			     scode = 0;		/* must reset to zero so that the next if statement will false */
			     i = i - 1;		/* want to reposition back to the original position */
			end;

		     if ^rtq_info.eof_request_flg & scode ^= 0 then do;

			     save_status_code = scode;
			     call get_tape_status;	/* get English desc of tape error */

			     call ssu_$print_message (sci_ptr, save_status_code,
				"^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while executing iteration # ^d of ^a control order",
				t_stat, (status_story ^= ""), status_story, i, a_order);
			     return;
			end;
		end;				/* scode ^= 0 */
	end;					/* do i = 1 to count */

	if backspace_file_flg then do;		/* if a backspace file operation */
		call iox_$control (rtq_info.tiocb_ptr, "forward_file", null, scode); /* position to beginning of next file */
		if scode ^= 0 then do;
			save_status_code = scode;
			call get_tape_status;	/* get English desc of tape error */

			call ssu_$print_message (sci_ptr, save_status_code,
			     "^/Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while forward spacing to beginning of file ^d",
			     t_stat, (status_story ^= ""), status_story, rtq_info.c_file);
			return;
		     end;
	     end;					/* a bsf command */

     end process_control_order;

/***************************************************************************/
%page;
process_logical_record_length: proc ();

/* users want each physical tape record to be written into several logical  */
/* records of a specified length.  So do it.                                */

/* begin coding */
	it_cnt = divide (rtq_info.rec_len - schar, l_rec_len, 17, 0); /* determine # of logical records */
	spill = mod (rtq_info.rec_len - schar, l_rec_len);/* get spill over if any */

	do i = 1 to it_cnt;
	     rtq_info.cbufp -> cbuf = chcv_buf (i);	/* copy logical record */
	     temp_logical_rec_len = l_rec_len;

	     if open_mode = Stream_output | open_mode = Stream_input_output then do;
		     substr (rtq_info.cbufp -> cbuf, l_rec_len + 1, 1) = NL; /* add NL to its end */
		     temp_logical_rec_len = temp_logical_rec_len + 1;
		end;

	     call write_file (rtq_info.cbufp, temp_logical_rec_len, s_filename); /* and write it out */

	     if rtq_info.return_subsys_loop_flg then
		return;

	end;

	if spill ^= 0 then do;			/* if some left over */
		it_cnt = it_cnt + 1;		/* need 1 more subsrcipt for spill */
		rtq_info.cbufp -> cbuf = substr (chcv_buf (it_cnt), 1, spill);

		if open_mode = Stream_output | open_mode = Stream_input_output then do;
			substr (rtq_info.cbufp -> cbuf, spill + 1, 1) = NL; /* copy spillover */
			spill = spill + 1;		/* for the NL */
		     end;

		call write_file (rtq_info.cbufp, spill, s_filename); /* and write it out too */

		if rtq_info.return_subsys_loop_flg then
		     return;

	     end;					/* process some record left over */

	return;

     end process_logical_record_length;

/***************************************************************************/
%page;
read_file_get_control_args: proc ();

/* process optional input control arguments for "read_file" request */

	do arg_dex = 1 to Nargs;
	     call ssu_$arg_ptr (sci_ptr, arg_dex, ap, al);
	     if arg = "-gcos" | arg = "-gc" then do;	/* file in gcos standard system format */
		     gssf = "1"b;
		     call check_mode (BINARY_MODE);	/* must read data in binary mode */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;

	     else if arg = "-multics" | arg = "-mult" then do; /* file in multics standard system format */
		     mssf = "1"b;
		     call check_mode (BINARY_MODE);	/* must read data in binary mode */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;

	     else if arg = "-extend" then /* if file extend option desired */
		rtq_info.extend_sw = "1"b;

	     else if arg = "-nnl" then /* if user don't want new line on raw File */
		nnl_sw = "1"b;

	     else if arg = "-output_description" | arg = "-ods" then /* user wants to attach spec device */
		rtq_info.atd_sw = "1"b;

	     else if arg = "-cp5" then do;		/* cp5 variable length records */
		     cp5 = "1"b;			/* set flag */
		     call check_mode (NINE_MODE);	/* must read data in nine bit mode */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;

	     else if arg = "-dec" then do;		/* DEC 40 bit word records */
		     lrp = rtq_info.cvbp;		/* set conversion buffer pointer */
		     dec_sw = "1"b;			/* set flag */
		     call check_mode (BINARY_MODE);	/* must read data in binary mode */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;

	     else if arg = "-ibm_vb" then do;		/* IBM "VB" records */
		     ibmv = "1"b;			/* set flag */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     if substr (arg, 1, 1) ^= "-" then do;
				     arg_dex = arg_dex + 1;
				     if arg = "binary" | arg = "bin" then
					rtq_info.set_bin = "1"b;
				     else if arg = "ebcdic" then
					c_e_a = "1"b;
				     else if arg ^= "ascii" then do;
IBM_VB_ERROR:
					     call ssu_$print_message (sci_ptr, 0,
						" Usage:  read_file (rdfile) {-ibm_vb {ascii | binary (bin) | ebcdic}}");
					     goto GET_CONTROL_ARG_ERROR;
					end;	/* else if arg ^= "ascii" */
				end;		/* if substr (arg, 1, 1) ^= "-" */
			     else c_e_a = "1"b;	/* ebcdic conversion by default */
			end;			/* arg_dex < Nargs */
		     else if arg_dex = Nargs then
			c_e_a = "1"b;		/* ebcdic conversion by default */
		     else goto IBM_VB_ERROR;
		     if rtq_info.set_bin then /* if we need to read in binary mode */
			call check_mode (BINARY_MODE);/* go set it */
		     else call check_mode (NINE_MODE);	/* otherwise read in nine mode */
		     n_ops = n_ops + 1;		/*  for inconsistancy  check */
		end;				/* else if arg = "-ibm_vb" */

	     else if arg = "-ansi_db" then do;		/* ANSI "DB" records */
		     ansid = "1"b;			/* set flag */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     if substr (arg, 1, 1) ^= "-" then do;
				     arg_dex = arg_dex + 1; /* advance argument index */
				     if arg = "binary" | arg = "bin" then
					rtq_info.set_bin = "1"b;
				     else if arg = "ebcdic" then
					c_e_a = "1"b;
				     else if arg ^= "ascii" then do;
ANSI_DB_ERROR:
					     call ssu_$print_message (sci_ptr, 0,
						"Usage:  read_file (rdfile) {-ansi_db {ascii | binary (bin) | ebcdic}}");
					     goto GET_CONTROL_ARG_ERROR;
					end;
				end;		/* if substr (arg, 1, 1) ^= "-" */
			end;			/* arg_dex < Nargs */
		     else if arg_dex > Nargs then
			goto ANSI_DB_ERROR;
		     else ;
		     if rtq_info.set_bin then /* if we need to read in binary mode */
			call check_mode (BINARY_MODE);/* go set it */
		     else call check_mode (NINE_MODE);	/* otherwise read in nine mode */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;				/* ANSI "DB" record */

	     else if arg = "-truncate" | arg = "-tc" then do; /* user wants to truncate phy records */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     tr_cnt = cv_dec_check_ (arg, scode);
			     if scode ^= 0 then do;
TC_ERROR:
				     call ssu_$print_message (sci_ptr, scode,
					"^/     Usage:  read_file (rdfile) {-truncate (-tc) N}");
				     goto GET_CONTROL_ARG_ERROR;
				end;
			     arg_dex = arg_dex + 1;	/* advance argument index */
			     trunc_sw = "1"b;
			end;			/* if arg_dex < Nargs */
		     else do;
			     scode = 0;
			     goto TC_ERROR;
			end;
		end;				/* -truncate (-tc) */

	     else if arg = "-logical_record_length" | arg = "-lrl" then do; /* process log records */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     l_rec_len = cv_dec_check_ (arg, scode);
			     if scode ^= 0 then do;
LRL_ERROR:
				     call ssu_$print_message (sci_ptr, scode,
					"^/     Usage:  read_file (rdfile) {-logical_record_length (-lrl) N}");
				     goto GET_CONTROL_ARG_ERROR;
				end;
			     arg_dex = arg_dex + 1;	/* advance argument index */
			     if l_rec_len > length (rtq_info.cbufp -> cbuf) then do; /* better to tell user of limitation */
				     call ssu_$print_message (sci_ptr, 0,
					"Logical record lengths > ^d characters not supported", length (rtq_info.cbufp -> cbuf));
				     goto GET_CONTROL_ARG_ERROR;
				end;
			     l_rec = "1"b;
			     n_ops = n_ops + 1;	/* increment for inconsistancy  check */
			end;			/* if arg_dex < Nargs */
		     else do;
			     scode = 0;
			     goto LRL_ERROR;
			end;
		end;				/* -logical_record_length (-lrl) */

	     else if arg = "-count" | arg = "-ct" then do;/* user wants to read multiple files */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     iterations = cv_dec_check_ (arg, scode); /* check for rdfile iterations */
			     if scode ^= 0 then do;
CNT_ERROR:
				     call ssu_$print_message (sci_ptr, scode,
					"^/     Usage:  read_file (rdfile) {-count (-ct) N}");
				     goto GET_CONTROL_ARG_ERROR;
				end;
			     arg_dex = arg_dex + 1;	/* advance argument index */
			end;			/* if arg_dex < Nargs */
		     else do;			/* missing N for -count */
			     scode = 0;
			     goto CNT_ERROR;
			end;
		end;				/* -count (-ct) */

	     else if arg = "-skip" then do;		/* user wants to skip some initial chars */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     schar = cv_dec_check_ (arg, scode);
			     if scode ^= 0 then do;
SKIP_ERROR:
				     call ssu_$print_message (sci_ptr, scode,
					"^/     Usage:  read_file (rdfile) {-skip N}");
				     goto GET_CONTROL_ARG_ERROR;
				end;
			     arg_dex = arg_dex + 1;	/* advance argument index */
			end;			/* if arg_dex < Nargs */
		     else do;
			     scode = 0;
			     goto SKIP_ERROR;
			end;
		end;				/* -skip */

	     else if arg = "-convert" | arg = "-conv" then do; /* user wants to do some conversion */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     arg_dex = arg_dex + 1;	/* advance argument index */
			     if arg = "ebcdic_to_ascii" | arg = "ebcdic" then
				c_e_a = "1"b;	/* convert ebcdic */
			     else if arg = "bcd_to_ascii" | arg = "bcd" then
				c_b_a = "1"b;	/* convert bcd */
			     else if arg = "comp8_to_ascii" | arg = "comp8" then do; /* convert comp8 to ascii */
				     c_c_a = "1"b;
				     call check_mode (NINE_MODE); /* must read data in nine bit mode */
				end;		/* com8_to_ascii (comp8) */
			     else do;
CONV_ERROR:
				     call ssu_$print_message (sci_ptr, 0,
					"Usage:  read_file (rdfile) {-convert (-conv) ebcdic_to_ascii (ebcdic) | bcd_to_ascii (bcd) | comp8_to_ascii (comp8)}");
				     goto GET_CONTROL_ARG_ERROR;
				end;
			end;			/* if arg_dex < Nargs */
		     else goto CONV_ERROR;

		     lrp = rtq_info.cvbp;		/* set conversion buffer pointer */
		     n_ops = n_ops + 1;		/* increment for inconsistancy  check */
		end;				/* -convert (-conv) */

	     else if arg = "-output_file" | arg = "-of" then do; /* user wants output file specified */
		     if arg_dex < Nargs then do;
			     call ssu_$arg_ptr (sci_ptr, arg_dex + 1, ap, al);
			     if substr (arg, 1, 1) ^= "-" then do; /* don't allow file name to begin with - */
				     arg_dex = arg_dex + 1; /* advance argument index */

				     if ^valid_pathname ((arg), "") then do; /* error expanding pathname */
OF_ERROR:
					     call ssu_$print_message (sci_ptr, scode,
						"^/     Usage:  read_file (rdfile) {-output_file (-of) FILE_NAME}");
					     goto GET_CONTROL_ARG_ERROR;
					end;

				end;
			end;			/* arg_dex < Nargs */
		     else do;
			     scode = 0;
			     goto OF_ERROR;
			end;
		end;				/* -output_file (-of) */

	     else do;
		     call ssu_$print_message (sci_ptr, 0,
			"Invalid input optional control argument ""^a""", arg);
		     goto GET_CONTROL_ARG_ERROR;
		end;
	end;					/* do i = 1 to Nargs */

	return;

GET_CONTROL_ARG_ERROR:
	rtq_info.return_subsys_loop_flg = "1"b;
	return;

     end read_file_get_control_args;

/***************************************************************************/
%page;
read_in_the_entire_file: proc ();

/* depending on the record format, process each record just read in until  */
/* end of file encountered.  If the file is in GCOS JCL then invoke        */
/* the "write_file" internal procedure to write end of job card.           */
/* Similarly, invoke the "MULT_ssf" to go flush buffer for Multics file.   */
/* Finally, if not extend the file then invokes the                        */
/* "detach_file_if_attached" to detach the file if it was already attached.*/

/* begin code */
	rtq_info.eof, binck = "0"b;
	do while (^rtq_info.eof);			/* read entire file */

	     call read_tape_record ("skip", rtq_info.eof, "0"b, mssf); /* read the next record */

	     if rtq_info.return_subsys_loop_flg then
		return;

	     if ^rtq_info.eof then do;		/* if not end of file */

		     if valid_label_record ("0"b) then /* if label record */
			goto nxt_rcd;		/* then don't process */

		     if trunc_sw then
			rtq_info.rec_len = tr_cnt;	/*  wants truncate phy record */

		     if gssf then
			call GCOS_ssf (cont, imcv, nchars, binck, first_record_flg, s_filename);

		     else if mssf then
			call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* MULTICS standard tape */

		     else if cp5 then
			call CP5_variable_length_records;

		     else if dec_sw then
			call DEC_tape_records;

		     else if ibmv then
			call IBM_VB_records;

		     else if ansid then do;
			     conversion_flg = "0"b;
			     call ANSI_DB_records (conversion_flg);
			     if conversion_flg then
				return;
			end;

		     else do;			/* not known format, check for conversion */
			     if c_e_a then do;	/* convert ebcdic to ascii */

				     if rtq_info.c_mode = NINE_MODE then /* if nine mode */
					call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf);
				     else do;
					     rtq_info.rec_len = divide (rtq_info.bits + 8 - 1, 8, 21, 0); /* correct record length */

					     call ebcdic8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
					end;
				end;		/* covert ebcdic to ascii */

			     else if c_b_a then do;	/* bcd to ascii conversion */
				     rtq_info.rec_len = divide (rtq_info.bits + 6 - 1, 6, 21, 0); /* correct record length */
				     call bcd_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
				end;		/* convert bcd to ascii */

			     else if c_c_a then do;	/* convert comp 8 to ascii */
				     rtq_info.rec_len = divide (rtq_info.bits + 4 - 1, 4, 21, 0); /* correct record length */
				     call comp_8_to_ascii_ (rtq_info.tptr -> bit_buf, rtq_info.cvbp -> cv_buf);
				end;		/* convert comp 8 to ascii */

			     if l_rec then
				call process_logical_record_length;

			     else if rtq_info.atd_sw | nnl_sw then /* let he writes to what he wants */
				call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len - schar, s_filename);

			     else do;		/* write a raw file by default */
				     substr (conv_buf.conv_dta, rtq_info.rec_len - schar + 1, 1) = NL;
                                                            /* to prevent string range condition */
				     rtq_info.rec_len = (rtq_info.rec_len - schar) + 1; /* set correct record length */

				     call write_file (addr (conv_buf.conv_dta), rtq_info.rec_len, s_filename);
				end;
			end;			/* unknown format */
		end;				/* if ^rtq_info.eof */

	     if rtq_info.return_subsys_loop_flg then
		return;

nxt_rcd:
	end;					/* do while ^rtq_info.eof */

	if gssf then do;
		if rtq_info.last_job_deck_flg then do;

			call write_file (addr (eoj_card), length (eoj_card), s_filename); /* if gcos jcl, write eoj card */

			if rtq_info.return_subsys_loop_flg then
			     return;
		     end;
	     end;

	if mssf then do;				/* if Multics standard system format */
		last_record_flg = "1"b;		/* don't forget last data in buffer */

		call MULT_ssf (first_record_flg, last_record_flg, s_filename); /* go flush buffer */

		if rtq_info.return_subsys_loop_flg then
		     return;
	     end;

	if ^rtq_info.extend_sw then /* if not extending this file */

	     call detach_file_if_attached;		/* just in case we had a file attached */

     end read_in_the_entire_file;

/***************************************************************************/
%page;
read_tape_record: proc (neg, end_file, quiet_sw, mssf);

/* read in the next sequential tape record in the file.  If the returned  */
/* scode value is zero then increment the record number by 1, set buffer  */
/* full flag so we can dump the record, calculate the record length in    */
/* bits, and reset the end of file flag.  If the returned scode value     */
/* indicates end of file encountered then if end of file flag or end of   */
/* volume flag was previously set then set end of tape flag, else set end */
/* of file flag.  If not suppress output then display appropriate         */
/* messages to users and adjust the record number to the first record in  */
/* the file.  Increment file number by 1, adjust the record length in     */
/* bits to zero, and set end_file flag indicating end of file             */
/* encountered.  If the returned scode value indicates tape error then    */
/* invoke "get_tape_status" to get tape error number and English          */
/* description.  If the tape error record is in Multics format then       */
/* re-try to read it again up to 10 times before reporting to users.      */
/* Ask users whether they want to retry again or to skip that error       */
/* record or to return to the rtq request loop.                           */

/* automatic storage */
	dcl     auto_retry		 fixed bin;
	dcl     end_file		 bit (1) aligned;
	dcl     explanation_string	 char (95);
	dcl     get_answer		 char (5) varying;	/* max len is 5 characters */
	dcl     mssf		 bit (1) aligned;
	dcl     neg		 char (6);
	dcl     query_flg		 bit (1) aligned;
	dcl     question_string	 char (20);
	dcl     quiet_sw		 bit (1) aligned;


/* begin coding */
	if rtq_info.two_eofs then goto gleot;		/* if gcos partial header label */

	end_file = "0"b;				/* reset eof indicator */
	auto_retry = 0;				/* intiialize auto retry count */

retry_rd:
	call iox_$read_record (rtq_info.tiocb_ptr, rtq_info.tptr, rtq_info.buf_size - NUMB_OF_CHARS_PER_WORD, rtq_info.rec_len, scode);
						/* minus 4 because must reserve 1 word for appending a New Line character after returning to the caller */
	if scode ^= 0 then do;

		if scode ^= error_table_$end_of_info then do;
			save_status_code = scode;
			call get_tape_status;	/* get English desc of tape error */

			if mssf then do;		/* reading a Multics standard system format tape */
				auto_retry = auto_retry + 1;
				if auto_retry > 10 then do; /* exceeded error threshold */
					call ssu_$print_message (sci_ptr, save_status_code,
					     "^/Tape status = ^4.3b.^/^[""^a""^;^1s^] ^/     Therefore, skipping record ^d, file ^d, ^a.",
					     t_stat, (status_story ^= ""), status_story, rtq_info.c_rec,
					     rtq_info.c_file, "due to unrecoverable read error");

					rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */
				     end;		/* exceeded error threshold */
				else call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode); /* back it up */

				go to retry_rd;	/* and go read next record */
			     end;			/* reading a MULTICS Standard Label tape */

			call ssu_$print_message (sci_ptr, save_status_code,
			     "Tape status = ^4.3b.^/^[ ""^a""^;,^1s^] while reading record ^d, file ^d",
			     t_stat, (status_story ^= ""), status_story, rtq_info.c_rec, rtq_info.c_file);

			if neg ^= "stop" then do;	/* neg = "skip" */
				explanation_string = "Do you want to retry, skip to the next record, or stop?  Answer ""retry"", ""skip"", or ""stop"".";
				question_string = "Retry, skip or stop?";
			     end;
			else do;			/* neg = "stop" */
				explanation_string = "Do you want to retry or stop?  Answer ""retry"" or ""stop"".";
				question_string = "Retry or stop?";
			     end;

			get_answer = command_query_no_entrypoint (explanation_string, question_string);

			query_flg = "1"b;
			do while (query_flg);
			     query_flg = "0"b;	/* exit do loop */
			     if get_answer = "retry" then do;
				     call iox_$control (rtq_info.tiocb_ptr, "backspace_record", null, scode);

				     if scode = error_table_$end_of_info then
					goto END_OF_INFO_REACHED;
				     else go to retry_rd;
				end;

			     else if get_answer = "skip" then do;
				     rtq_info.c_rec = rtq_info.c_rec + 1; /* increment record number */
				     go to retry_rd;/* and go read it */
				end;

			     else if get_answer = "stop" then do;
				     rtq_info.return_subsys_loop_flg = "1"b;
				     end_file = "1"b; /* indicate error */
				     return;	/* return to request loop */
				end;

			     else do;
				     get_answer = command_query_no_entrypoint (explanation_string, question_string);

				     query_flg = "1"b;
				end;
			end;			/* do while */
		     end;				/* if scode ^= error_table_$end_of_info */

		else do;				/* end of file */
END_OF_INFO_REACHED:
			if rtq_info.one_eof | rtq_info.eov then rtq_info.two_eofs = "1"b; /* indicate physical end of tape */
			else rtq_info.one_eof = "1"b; /*  no set one eof indicator */

gleot:
			if ^quiet_sw then do;	/* if not suppressing output */
				if rtq_info.two_eofs then do; /* if at physical end of tape, tell user */
					call ioa_ ("End of file encountered on file # ^d.  No data read.", rtq_info.c_file);

					call ioa_ ("Logical end of tape at physical file # ^d", rtq_info.c_file);
				     end;
				else do;
					if rtq_info.c_rec = 1 then do;
						call ioa_ ("End of file encountered on file # ^d.  No data read.", rtq_info.c_file);

						call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
					     end;
					else do;
						call ioa_ ("End of file after ^d record^[s^] read from tape file # ^d",
						     rtq_info.c_rec - 1, (rtq_info.c_rec > 2), rtq_info.c_file);
						call ioa_ ("Positioning to start of file # ^d.", rtq_info.c_file + 1);
					     end;
				     end;

				rtq_info.c_rec = 1; /* reset record number */
			     end;

			rtq_info.c_file = rtq_info.c_file + 1; /* increment file number */
			rtq_info.bits = 0;		/* reset number of bits */
			end_file = "1"b;		/* and turn on eof indicator */
		     end;				/* end of file */
	     end;					/* scode ^= 0 */
	else do;					/* scode = 0 */
		rtq_info.c_rec = rtq_info.c_rec + 1;	/* no tape errors, increment record number */
		rtq_info.buf_ful = "1"b;		/* set buffer ful switch so we can dump record */
		rtq_info.bits = rtq_info.rec_len * 9;	/* and calculate bit len of record */
		rtq_info.one_eof = "0"b;		/* reset one eof indicatior if set */
	     end;

     end read_tape_record;

/***************************************************************************/
%page;
record_information: proc (numrecs, nbits, rcd_tally);

/* display a record length in bits, words, nine-bit bytes, eight-bit bytes, */
/* and in six-bit characters.                                               */

	dcl     (bit6, bit8, bit9)	 fixed bin (35) init (0);
	dcl     (nbits, numrecs)	 fixed bin (35);
	dcl     rcd_tally		 bit (1);

/* begin coding */
	if ^rcd_tally then /* if called from rdrec request */
	     if valid_label_record ("1"b) then return;	/* check for valid label record */

	nwds = divide (nbits, 36, 35);
	bit9 = divide (nbits, 9, 35);
	bit8 = divide (nbits, 8, 35);
	bit6 = divide (nbits, 6, 35);

	call ioa_ ("^[  ^d record^[s^]:^;^2sRecord^] ^a ^d ^a, ^d ^a, ^d ^a,^[^/    ^-^[^- ^;^6x^]^;^1s ^]   ^d ^a, ^d ^a",
	     rcd_tally, numrecs, (numrecs > 1), "length =", nbits, "bits", nwds, "words", bit9,
	     "nine bit bytes", rtq_info.short_output_flg, rcd_tally, bit8, "eight bit bytes", bit6, "six bit chars");

     end record_information;

/***************************************************************************/
%page;
valid_label_record: proc (lg_ck) returns (bit (1) aligned);

/* determines that the record is a LABEL/TRAILER record and displays its   */
/* contents if it is.                                                      */

	dcl     ansi_hdr2_fmt	 char (108) int static options (constant) init
				 ("Record format ^a^[^[B^]^;^1s^]; Block length ^d; Record length ^d; Mode ^[ASCII^;EBCDIC^;BINARY^;UNKNOWN^];");

	dcl     (eov, lg_ck)	 bit (1) aligned;

/* begin coding */
	go to lab_type (rtq_info.l_type);		/* check for LABEL records first */

lab_type (1):					/* check for MULTICS label records */
	if rtq_info.tptr -> mstr.head.label then do;	/* Multics tape label record */
		call ioa_ ("^[^/^] ^a version ^[2^;1^] label record for volume ^a", (rtq_info.c_rec = 2),
		     LABEL (rtq_info.l_type), (unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3), rtq_info.tptr -> mult.tape_reel_id);

		if lg_ck then do;			/* if user wants more info... */
			if substr (rtq_info.tptr -> mstr.head.uid, 18, 1) then /* if uid generated by unique_bits_... */
			     call date_time_ (bin (substr (rtq_info.tptr -> mstr.head.uid, 19, 52), 71), time_string);
			else call date_time_ (bin (rtq_info.tptr -> mstr.head.uid, 71), time_string);

			call ioa_ ("Tape created on:^-^a", time_string);

			if rtq_info.tptr -> mult.installation_id ^= "" then /* and this exists then give it to him */
			     call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mult.installation_id);

			if unspec (substr (rtq_info.tptr -> mult.volume_set_id, 1, 1)) ^= "777"b3 then /* if version 2 label */
			     if rtq_info.tptr -> mult.volume_set_id ^= "" then /* and volume set exists.. */

				call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mult.volume_set_id);
		     end;				/* if log_ck */
	     end;					/* Multics tape LABEL record */

	else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */
	     call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
	else return ("0"b);				/* not Multics tape label record */

	return ("1"b);				/* was label record, return true */


lab_type (2):					/* check for version 2 Multics label records */
	if rtq_info.c_file = 1 & rtq_info.tptr -> mst_label.head.label then do; /* if Multics tape label record */
		call ioa_ ("^[^/^] ^a version ^d label record for volume ^a", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type),
		     rtq_info.tptr -> mst_label.label_version, rtq_info.tptr -> mst_label.tape_reel_id);

		if lg_ck then do;			/* if user wants more info */
			if substr (rtq_info.tptr -> mst_label.head.uid, 18, 1) then /* if uid generated by unique_bits_... */
			     call date_time_ (bin (substr (rtq_info.tptr -> mst_label.head.uid, 19, 52), 71), time_string);
			else call date_time_ (bin (rtq_info.tptr -> mst_label.head.uid, 71), time_string);

			call ioa_ ("Tape created on:^-^a", time_string);

			if rtq_info.tptr -> mst_label.installation_id ^= "" then /* if one exists, print it */
			     call ioa_ ("Tape created at:^-^a", rtq_info.tptr -> mst_label.installation_id);

			if rtq_info.tptr -> mst_label.userid ^= "" then /* if one exists, print it */
			     call ioa_ ("Tape created by:^-^a", rtq_info.tptr -> mst_label.userid);

			if rtq_info.tptr -> mst_label.boot_pgm_path ^= "" then /* if one exists, print it */
			     call ioa_ ("Boot program path:^-^a", rtq_info.tptr -> mst_label.boot_pgm_path);

			if rtq_info.tptr -> mst_label.volume_set_id ^= "" then /* if this exists, print it */
			     call ioa_ ("Volume Set Name:^-^a", rtq_info.tptr -> mst_label.volume_set_id);

			if rtq_info.tptr -> mst_label.copyright ^= "" then /* if protection notice exits, print it */
			     call ioa_ ("Protection Notice:^-^a", rtq_info.tptr -> mst_label.copyright);
		     end;				/* if lg_ck */
	     end;					/* it is file 1 and it is MULTICS tape Label record */

	else if rtq_info.tptr -> mstr.head.eor then /* if end of reel record */
	     call ioa_ ("^[^/^] ^a end of reel record", (rtq_info.c_rec = 2), LABEL (rtq_info.l_type));
	else return ("0"b);				/* not Multics tape label record */

	return ("1"b);				/* was label record, return true */


lab_type (3):					/* check for GCOS Label records */
	if rtq_info.bits = 504 then do;		/* if gcos tape label or eof record */
		call bcd_to_ascii_ (bit_buf, rtq_info.cbufp -> cbuf); /* convert bcd to ascii */

		if gcos.lab_id = g_label then do;	/* if header label */
			if substr (bit_buf, 145, 216) = "0"b then do; /* partial hdr label */
				rtq_info.eov, rtq_info.two_eofs = "1"b; /*  logical end of tape */
				j = 24;		/* set character count */
			     end;
			else j = 60;		/* normal hdr label */

			call ioa_ ("^a ^[Partial ^]^[BTL ^]^a^[; Tape reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]^[^/^]",
			     LABEL (rtq_info.l_type), eov, (rtq_info.c_file = 1), "header label record", (rtq_info.c_file ^= 1),
			     substr (rtq_info.cbufp -> cbuf, 19, 6), lg_ck, substr (rtq_info.cbufp -> cbuf, 1, j), eov);
		     end;				/* label header */

		else call ioa_ ("^/^a ""^a"" label record. ^a ^d^[; Next reel # ^a^;^1s^].^[^/(""^a"")^;^1s^]",
			LABEL (rtq_info.l_type), substr (rtq_info.cbufp -> cbuf, 2, 3), "Block count of previous file",
			bin (substr (bit_buf, 37, 36)), (substr (rtq_info.cbufp -> cbuf, 79, 6) ^= ""),
			substr (rtq_info.cbufp -> cbuf, 79, 6), lg_ck, rtq_info.cbufp -> cbuf);
		return ("1"b);
	     end;					/* GCOS Label record */

	else return ("0"b);				/* not label record  */


lab_type (4):					/* check for IBM Label records */
	if rtq_info.rec_len = 80 then do;		/* it looks like a label record */
		call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */
		rtq_info.lblp = rtq_info.cvbp;	/* set label ptr */
		go to ibm_asc_join;			/* go join common code */
	     end;

	else return ("0"b);				/* not label/trailer return false */


lab_type (5):					/* check for ANSI Label records */
	if rtq_info.rec_len = 80 then do;		/* it looks like a label/trailer record */
		rtq_info.lblp = rtq_info.tptr;	/* set label ptr */

ibm_asc_join:					/* code from now on common for ibm and ansi */

		if substr (lab_buf, 1, 4) = "VOL1" then /* vol1 label */
		     call ioa_ ("^[^/^] ^a ^a label record. Volume serial number ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
			LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 6), lg_ck, lab_buf);

		else if substr (lab_buf, 1, 4) = "HDR1" then /* hdr1 label */
		     call ioa_ ("^[^/^] ^a ^a label record. Data set ID ^a^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
			LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), substr (lab_buf, 5, 17), lg_ck, lab_buf);

		else if substr (lab_buf, 1, 4) = "HDR2" then do; /* hdr2 label */
			call ioa_ ("^a ^a label record. Next file format:", LABEL (rtq_info.l_type), substr (lab_buf, 1, 4));

			if rtq_info.l_type = ibm_label then do; /* IBM HDR2 Label */
				ibm_hdr2P = rtq_info.lblp; /* set structure ptr */
				call ioa_ ("Record format ^a^a; Block length ^d; Record length ^d;",
				     ibm_hdr2.format, ibm_hdr2.block_attribute, bin (ibm_hdr2.blksize), bin (ibm_hdr2.lrecl));
			     end;
			else do;			/* ANSI HDR2 Label */
				ansi_hdr2P = rtq_info.lblp; /* set structure ptr */
				ansi_mode = index ("123", ansi_hdr2.mode); /* convert recording mode */

				if ansi_mode = 0 then ansi_mode = 4; /* this is an unknown mode */
				call ioa_ (ansi_hdr2_fmt, ansi_hdr2.format, (ansi_hdr2.blocked = "0" | ansi_hdr2.blocked = "1"),
				     (ansi_hdr2.blocked = "1"), bin (ansi_hdr2.blklen), bin (ansi_hdr2.reclen),
				     ansi_mode);

				if ansi_mode = 3 then /* if file in binary mode */
				     rtq_info.set_bin, rtq_info.set_nine = "1"b; /* set state switches */
			     end;			/* ANSI HDR2 Label */

			if lg_ck then call ioa_ ("(""^a"")", lab_buf);
		     end;				/* HDR2 Label */

		else if substr (lab_buf, 1, 3) = "EOV" | substr (lab_buf, 1, 3) = "EOF" |
		     substr (lab_buf, 1, 3) = "UHL" | substr (lab_buf, 1, 3) = "UTL" then do; /* one of these labels */
			call ioa_ ("^[^/^] ^a ^a label record. ^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
			     LABEL (rtq_info.l_type), substr (lab_buf, 1, 4), lg_ck, lab_buf);

			if substr (lab_buf, 1, 3) = "EOV" then eov = "1"b; /* Logical End tape */
		     end;				/* EOV Label or EOF Label or UHL Label or UTL Label */

		else return ("0"b);			/* none of known labels */

		return ("1"b);			/* if one of these: VOL1, HDR1, HDR2, EOV, EOF, UHL, and UTL labels */
	     end;					/* if rtq_info.rec_len = 80 */

	else return ("0"b);				/* not a Label or Trailer record */


lab_type (6):					/* check for CP5 Label records */
	if substr (bit_buf, 1, 9) ^= "172"b3 then /* if first char not = ebcdic ":" */
	     return ("0"b);				/* then its not label record */

	call ebcdic_to_ascii_ (rtq_info.tptr -> char_buf, rtq_info.cvbp -> cv_buf); /* convert ebcdic to ascii */
	rtq_info.lblp = rtq_info.cvbp;		/* set label ptr */

	if sentinel = ":LBL" | sentinel = ":ACN" | sentinel = ":BOF" |
	     sentinel = ":EOV" | sentinel = ":EOR" | sentinel = ":EOF" then do;
		call ioa_ ("^[^/^] ^a ^a label record^[; Volume id ^a^;^1s^].^[^/(""^a"")^;^1s^]^/", (rtq_info.c_rec = 2),
		     LABEL (rtq_info.l_type), sentinel, (sentinel = ":LBL"), substr (lab_buf, 5, 4), lg_ck, lab_buf);
		return ("1"b);			/* return true */
	     end;
	else return ("0"b);				/* otherwise, return false */


lab_type (0):					/* unlabeled tape, egnore looking at labels */
	return ("0"b);				/* not label record */

     end valid_label_record;

/***************************************************************************/
%page;
valid_pathname: proc (pathname_argument, suffix) returns (bit (1) aligned);

/* expands a specified entry name to a directory pathname and appends a    */
/* specified suffix to an entry name.  Returns a "1"b indicating success,  */
/* otherwise, returns a "0"b.                                              */

	dcl     p_dir		 char (168);
	dcl     p_entry		 char (32);
	dcl     pathname_argument	 char (*);
	dcl     suffix		 char (*);

/* begin coding */
	call expand_pathname_$add_suffix (pathname_argument, suffix, p_dir, p_entry, scode);
	if scode ^= 0 then
	     return ("0"b);
	else do;
		rtq_info.filename = p_entry;
		rtq_info.filepath = pathname_ (p_dir, p_entry);
		return ("1"b);
	     end;

     end valid_pathname;

/***************************************************************************/
%page;
write_file: proc (bufptr, wrtchars, s_file_name);

/* writes logical records to a specified file:  If users don't specify a   */
/* file then they will be asked for a file name.  If users don't specify a */
/* file format then displays a warning message and query them before       */
/* we write a raw file.  Builds the attach description before attaching    */
/* and opening the file using vfile_ i/o module.  Reports to users if the  */
/* output file has not been written yet.  Depending on the open mode,      */
/* writes each logical record to the output file.  Queries users for       */
/* re-trying to write again if the returned scode value is not a zero      */
/* value.                                                                  */

	dcl     bufptr		 ptr;
	dcl     output_filename	 char (168) aligned;
	dcl     s_file_name		 char (32) varying;
	dcl     wrtchars		 fixed bin (21);	/* written characters */

/* begin coding */
	if ^rtq_info.f_attached then do;		/* if file not attached */
		if rtq_info.filename = "" then do;	/* if no filename, go ask for it */
			rtq_info.tmr = "0"b;	/* initialize terminate condition */
			do while (^rtq_info.tmr);	/* if no filename */
			     output_filename = command_query_no_entrypoint ("Please enter an output file name.", "Output file name:  ");

			     rtq_info.tmr = valid_pathname ((output_filename), "");
			     if ^rtq_info.tmr then do;
				     call ssu_$print_message (sci_ptr, scode,
					"Expanding pathname while writing to the ouput file name ""^a""",
					output_filename);

				     rtq_info.return_subsys_loop_flg = "1"b;
				     return;
				end;
			end;			/* do while ^rtq_info.tmr */
		     end;				/* if rtq_info.filename = "" */

		if ^nnl_sw & n_ops = 0 & s_file_name = "" then do; /* warn user before we write raw file */

			call ioa_ ("Warning:  Tape file # ^d will be written to stream file ^a.^/A new line " ||
			     "character (octal 012) will be appended to the end of each physical record.",
			     rtq_info.c_file, rtq_info.filename);

			YES_FLG = command_query_yes_no ("Do you want to add a new line character to each physical record?  Answer ""yes"" or ""no"".", "Append a new line character?");

			if ^YES_FLG then do;	/* users said no */
				rtq_info.return_subsys_loop_flg = "1"b;
				return;
			     end;
		     end;				/* if ^nnl_sw & n_ops = 0 & s_file_name = ""  */

		att_desc = "vfile_ " || rtq_info.filepath; /* build attach description now  */

/* attach and open the output file */
		call attach_and_open_output_file;
	     end;					/* if ^rtq_info.f_attached */

	if ^rtq_info.fw_file then do;			/* if first record of file */
		rtq_info.fw_file = "1"b;		/* set switch */
		if ^rtq_info.atd_sw then /* if user not using his own attach desc */
		     call ioa_ ("Writing file ""^a"".", rtq_info.filepath);
	     end;

RETRY_WRITE:
	if open_mode = Stream_output | open_mode = Stream_input_output then /* if open for "so" or "sio" */
	     call iox_$put_chars (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */
	else call iox_$write_record (rtq_info.fiocb_ptr, bufptr, wrtchars, scode); /* write out logical records */

	if scode ^= 0 then do;
		call ssu_$print_message (sci_ptr, scode, "while writing to ""^a""", att_desc);

		YES_FLG = command_query_yes_no ("Do you want to retry?  Answer ""yes"" or ""no"".", "Retry?");

		if YES_FLG then /* users want to retry */
		     goto RETRY_WRITE;
	     end;

     end write_file;

/***************************************************************************/
%page;
%include rtq_structure_info;
%page;
%include ibm_hdr2;
%include ansi_hdr2;
%page;
%include mstr;
%include gcos_ssf_records;
%page;
%include iox_modes;
%include area_info;

     end rtq_;




		    rtq_request_table_.alm          07/28/87  0923.2rew 07/28/87  0918.5       28215



" ********************************************
" *                                          *
" * Copyright, (C) Honeywell Bull Inc., 1987 *
" *                                          *
" ********************************************
           
" HISTORY COMMENTS:
"  1) change(87-05-28,TLNguyen), approve(87-05-28,MCR7692),
"     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
"     implement read_tape_and_query (rtq) nonstandard subsystem as a standard
"     ssu_ subsystem.
"     rtq_request_table_.alm defines each request of read_tape_and_query
"     subsystem.
"  2) change(87-07-10,TLNguyen), approve(87-07-10,MCR7727),
"     audit(87-07-15,Blair), install(87-07-28,MR12.1-1048):
"     Add two new requests: rif, eof.
"                                                      END HISTORY COMMENTS

name       rtq_request_table_
	
	include	  ssu_request_macros

	
	begin_table rtq_request_table_
	
	request	   bof,
		    rtq_$bof_request,
		    (),
		    (Position to the beginning of the current physical tape file)

	request	   bsf,
		    rtq_$bsf_request,
		    (),
		    (Backspace N files)

	request	   bsr,
		    rtq_$bsr_request,
		    (),
		    (Backspace N records)

	request      density,
		    rtq_$density_request,
		    (den),
		    (Sets the tape density to a N bit per inch)

	request      dump,
		    rtq_$dump_record_request,
		    (),
	              (Displays the contents of the record buffer on the users terminal)

	request      eof,
	              rtq_$eof_request,
		    (),
	              (Positions to the end of the current physical tape file, after the last record)

	request	   fsf,
		    rtq_$fsf_request,
		    (),
		    (Forward space N files)

	request	   fsr,
		    rtq_$fsr_request,
		    (),
		    (Forward space N records)

	request	   list_tape_contents,
		    rtq_$list_tape_contents,
		    (ltc),
		    (Displays information about each record on the tape)

	request	   mode,
		    rtq_$mode_request,
		    (),
	              (Sets the hardware mode for reading tape to STR)
	            
	request	   position,
		    rtq_$position_request,
		    (pos),
	              (Displays the current physical tape file and record position for the user)

	request      quit,
		    rtq_$quit_request,
		    (q),
		    (Detaches the tape and returns control to the current command processor)

	request	   read_file,
	              rtq_$read_file_request,
		    (rdfile),
		    (Reads the current tape file into the segment described by args)

	request	   read_record,
		    rtq_$read_record_request,
	              (rdrec),
	              (Reads the current record into a temporary buffer)

          request      records_in_file,
	              rtq_$records_in_file_request,
	              (rif),
	              (Counts the number of records in the current file)

	request	   rewind,
		    rtq_$rewind_request,
		    (rew),
		    (Rewinds and positions the tape to the beginning of the tape marker)
	
	request	   .,
		    rtq_$dot_request,
	              (dot),
		    (Displays the long name read_tape_and_query with its short name in parentheses)

		   end_table rtq_request_table_

		   end
	




		    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
