



		    ascii_to_ebcdic_.alm            11/04/82  1931.3rew 11/04/82  1632.3       32211



" ***************************************************************
" *                                                             *
" * Copyright, (C) Honeywell Information Systems Inc., 1982     *
" *                                                             *
" * Copyright (c) 1975 by Massachusetts Institute of Technology *
" *                                                             *
" ***************************************************************



"ALM subroutine to convert from 9 bit ASCII to 9 bit EBCDIC
"input bytes must be valid ASCII characters whose octal values
"fall in the range 000 <_ octal_value <_ 177
"
"ARG 1: pointer to source string - data to be converted
"ARG 2: pointer to target string - converted data
"
"PL/I Usage:
"
"dcl  ascii_to_ebcdic_ ext entry (char (*), char (*));
"    call ascii_to_ebcdic_ (input_string, output_string);
"
"
"Note: the ASCII to EBCDIC mapping used is defined in the
"      text of this procedure.  It is available to a user
"      program through the following declaration.
"
"dcl  ascii_to_ebcdic_$ae_table char (128) external static;
"
"The table consists of 128 EBCDIC characters which
"correspond to the 128 ASCII characters.  The first character
"corresponds to 000, the 2nd to 001, ....., the 128th
"to 177.
"
"    0)  Created by Ross E. Klinger, 02/14/74
"    1)  Modified by R.E. Klinger, 03/13/75
                    name      ascii_to_ebcdic_
		segdef	ascii_to_ebcdic_
		segdef	ae_table
ascii_to_ebcdic_:	epp1	ap|2,*		address of source string to pr1
		epp3	ap|4,*		address of target string to pr3
		ldx3	0,du		set x3 not to skip parent pointer if none
		lxl2	ap|0		load argument list code value
		canx2	=o000004,du	check for code 4 - no parent pointer
		tnz	*+2		transfer if no parent pointer
		ldx3	2,du		parent pointer - set x3 to skip it
		lda	ap|6,x3*		load source string descriptor
		ldq	ap|8,x3*		load target string descriptor
		ana	mask		drop all but string size bits
		anq	mask		ditto
		even
		mvt	(pr,rl),(pr,rl),fill(040)	translate ascii to ebcdic
		desc9a	1|0,al		source string
		desc9a	3|0,ql		target string
		arg	ae_table
		short_return		"exit

mask:		oct	000077777777
		even
"			EBCDIC OUTPUT	EBCDIC GRAPHIC	HEXADECIMAL
ae_table:		oct	000001002003	NUL,SOH,STX,ETX	00,01,02,03
		oct	067055056057	EOT,ENQ,ACK,BEL	37,2D,2E,2F
		oct	026005045013	BS,HT,NL,VT	16,05,25,0B
		oct	014015016017	NP,CR,SO,SI	0C,0D,0E,0F
		oct	020021022023	DLE,DC1,DC2,TM	10,11,12,13
		oct	074075062046	DC4,NAK,SYN,ETB	3C,3D,32,26
		oct	030031077047	CAN,EM,SUB,ESC	18,19,3F,27
		oct	034035036037	IFS,IGS,IRS,IUS	1C,1D,1E,1F
		oct	100132177173	space,!,",#	40,5A,7F,7B
		oct	133154120175	$,%,&,apostrophe	5B,6C,50,7D
		oct	115135134116	(,),*,+		4D,5D,5C,4E
		oct	153140113141	",",-,.,/		6B,60,4B,61
		oct	360361362363	0,1,2,3		F0,F1,F2,F3
		oct	364365366367	4,5,6,7		F4,F5,F6,F7
		oct	370371172136	8,9,:,";"		F8,F9,7A,5E
		oct	114176156157	<,=,>,?		4C,7E,6E,6F
		oct	174301302303	@,A,B,C		7C,C1,C2,C3
		oct	304305306307	D,E,F,G		C4,C5,C6,C7
		oct	310311321322	H,I,J,K		C8,C9,D1,D2
		oct	323324325326	L,M,N,O		D3,D4,D5,D6
		oct	327330331342	P,Q,R,S		D7,D8,D9,E2
		oct	343344345346	T,U,V,W		E3,E4,E5,E6
		oct	347350351255	X,Y,Z,[		E7,E8,E9,AD
		oct	340275137155	\,],^,_		E0,BD,5F,6D
		oct	171201202203	`,a,b,c		79,81,82,83
		oct	204205206207	d,e,f,g		84,85,86,87
		oct	210211221222	h,i,j,k		88,89,91,92
		oct	223224225226	l,m,n,o		93,94,95,96
		oct	227230231242	p,q,r,s		97,98,99,A2
		oct	243244245246	t,u,v,w		A3,A4,A5,A6
		oct	247250251300	x,y,z,{		A7,A8,A9,C0
		oct	117320241007	solid bar,},~,DEL	4F,D0,A1,07

		end




		    tape_ansi_attach_.pl1           12/17/86  0926.4r w 12/17/86  0829.4      248814



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



/****^  HISTORY COMMENTS:
  1) change(86-08-18,GWMay), approve(), audit(), install():
     old history comments:
     0) Created:
     1) Modified: 04/11/79 C. D. Tavares
       for authentication and resource management.
     2) Modified: 06/29/79 Rick Riley
        allow reading and writing ibm tapes in binary mode.
     3) Modified: 9/79 R.J.C. Kissel
        to handle 6250 bpi tapes.
     4) Modified: 10/01/80 C. D. Tavares
        allow ibm file names to be > 8 chars if they contain periods.
     5) Modified: 9/81 M.R. Jordan
        to fix bugs whereby io_call attachments would fail and not report errors.
     6) Modified: 4/82 by J. A. Bush to allow blocksizes > 8192 bytes.
  2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-15,Dupuis),
     install(86-09-24,MR12.0-1162):
     Changed to accommodate error message lengths > 32 chars.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tape_ansi_attach_:
     procedure;					/* this entry not used */
	return;

/* parameters */
dcl      iocbP		  ptr,			/* pointer to iocb */
         options		  (*) char (*) varying,	/* array of attachment options */
         comerr		  bit (1) aligned,		/* "1"b if com_err_ can be called */
         code		  fixed bin (35);		/* error code */

%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;

%include tape_ansi_fl;

%include tape_attach_options;

%include rcp_volume_formats;

%include rcp_resource_types;


/* automatic storage */
dcl      1 auto_tao		  like tao auto;		/* tape attach options */

dcl      area_size		  fixed bin (26),		/* size of allocation area */
         block_attribute	  bit (1),		/* "0"b - unblocked | "1"b - blocked */
         drop		  fixed bin,		/* number of drives to be freed */
         error_msg		  char (80) varying init (""),/* attach option error message */
         format_code	  fixed bin init (0),	/* format code */
         (i, j)		  fixed bin,
         mask		  bit (36) aligned,		/* IPS mask word */
         part_file_name	  char (17) varying,	/* temp for validating labels */
         standard		  fixed bin,		/* tape standard code */
         temp_file_name	  char (17),		/* temp for validating labels */
         blocksize		  fixed bin,		/* size of tseg buffers in chars */
         tstring		  char (256) varying;	/* temporary attach description */

/* builtin functions */
dcl     (addr, after, before, index, length, min, mod, null, rtrim, size, string, substr, verify)
			  builtin;

/* conditions */
dcl      (any_other, area, cleanup)
			  condition;

/* internal static */
dcl      module_name	  (2) char (12) varying internal static
			  init /* IO Module name */ ("tape_ansi_", "tape_ibm_");
dcl      system_code	  (2) char (13) internal static
			  init /* system code for HDR1 label */ ("MULTICS ANSI ", "MULTICS IBM  ");

dcl      1 format		  internal static,		/* -format interpretation */
	 2 type		  (2, 7) char (4) varying
			  init
			  /* possibilities */ ("u", "fb", "f", "db", "d", "sb", "s", "u", "fb", "f", "vb", "v",
			  "vbs", "vs"),
	 2 fcode		  (2, 7) fixed bin
			  init /* interpretation - format code */ (1, 2, 2, 3, 3, 4, 4, 1, 2, 2, 3, 3, 4, 4),
	 2 blkatrib	  (2, 7) bit (1)
			  init
			  /* interpretation - blocking attribute */ ("0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "0"b,
			  "1"b, "0"b, "1"b, "0"b, "1"b, "0"b);

dcl      1 ibm_verifies	  unaligned internal static options (constant),
	 2 ibm_verify1	  char (55) init ("@#$ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),
						/* letters and national characters */
	 2 ibm_verify2	  char (11) init ("0123456789-");
						/* numbers and hyphen */

/* external static */
dcl      (
         error_table_$noalloc,
         error_table_$noarg,
         error_table_$not_detached,
         error_table_$unable_to_do_io,
         error_table_$file_busy,
         error_table_$inconsistent,
         error_table_$invalid_cseg,
         error_table_$bad_arg
         )		  fixed bin (35) ext static;
dcl      sys_info$max_seg_size  fixed bin (35) ext static;


/* external procedures */
dcl      area_		  ext entry (fixed bin (26), ptr),
         canon_for_volume_label_
			  entry (char (*), char (*), char (*), fixed bin, fixed bin (35)),
         clock_		  ext entry returns (fixed bin (71)),
         com_err_		  ext entry options (variable),
         continue_to_signal_	  ext entry (fixed bin (35)),
         tape_ansi_control_	  ext entry (ptr, char (*), ptr, fixed bin (35)),
         datebin_		  ext
			  entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
			  fixed bin, fixed bin, fixed bin),
         datebin_$dayr_clk	  ext entry (fixed bin (71), fixed bin),
         tape_ansi_detach_	  ext entry (ptr, fixed bin (35)),
         tape_ansi_file_cntl_$open
			  ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
         hcs_$delentry_seg	  ext entry (ptr, fixed bin (35)),
         hcs_$make_seg	  ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
         hcs_$reset_ips_mask	  ext entry (bit (36) aligned, bit (36) aligned),
         hcs_$set_ips_mask	  ext entry (bit (36) aligned, bit (36) aligned),
         hcs_$truncate_seg	  ext entry (pointer, fixed bin (18), fixed bin (35)),
         iox_$propagate	  ext entry (ptr),
         tape_ansi_mount_cntl_$free
			  ext entry (ptr, fixed bin, fixed bin (35)),
         tape_ansi_mount_cntl_$insert_rings
			  ext entry (ptr, fixed bin (35)),
         tape_ansi_mount_cntl_$mount
			  ext entry (ptr, fixed bin, fixed bin (35)),
         tape_ansi_mount_cntl_$write_permit
			  ext entry (ptr, fixed bin (35)),
         tape_ansi_mount_cntl_$write_protect
			  ext entry (ptr, fixed bin (35)),
         tape_ansi_nl_file_cntl_$open
			  ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
         tape_ansi_parse_options_
			  ext entry (ptr, (*) char (*) varying, char (*) varying, fixed bin (35)),
         tape_ansi_attach_$no_user_routine
			  ext entry options (variable),
         tape_ansi_tape_io_$attach
			  ext entry (ptr),
         terminate_process_	  ext entry (char (*), ptr);

tape_ansi_attach:
     entry (iocbP, options, comerr, code);
	standard = 1;				/* indicate tape_ansi_ entry */
	go to common;

tape_ibm_attach:
     entry (iocbP, options, comerr, code);
	standard = 2;				/* indicate tape_ibm_ entry */

common:
	if iocbP -> iocb.attach_descrip_ptr ^= null then do;
						/* is iocb already attached? */
	     code = error_table_$not_detached;
	     error_msg = iocbP -> iocb.name;
	     goto bad_attopt;
	end;

	taoP = addr (auto_tao);			/* base tao on automatic storage */
	call tao_init;				/* initialize the attach option structure */
	call tape_ansi_parse_options_ (taoP, options, error_msg, code);
						/* evaluate attach options */
	if code ^= 0 then do;			/* did an error occur? */
bad_attopt:
	     if comerr then
		call com_err_ (code, module_name (standard), "^a", error_msg);
						/* write msg if permitted */
	     return;
	end;

	call check_attopt (error_msg, code);		/* check if all ok for this IO Module */
	if code ^= 0 then
	     go to bad_attopt;
	if tao.blklen <= 8192 then			/* if standard block size.. */
	     blocksize = 8192;			/* set buffer size for 2K words */
	else do;					/* non-standard block size wanted */
	     if standard = 1 then			/* if tape_ansi_ attachment */
		if tao.blklen > 99996 then do;	/* if block size > max, complain */
		     error_msg = "Block size > 99996 bytes not allowed";
		     code = error_table_$bad_arg;
		     go to bad_attopt;
		end;
		else ;
	     else if tao.blklen > 32760 then do;	/* tape_ibm_ block size > max, complain */
		error_msg = "Block size > 32760 bytes not allowed";
		code = error_table_$bad_arg;
		go to bad_attopt;
	     end;

	     blocksize = tao.blklen;			/* set the desired block size */
	end;
	cP = null;				/* dont' try to cleanup non-existent stuff */
	on cleanup call cleaner;			/* don't leave segments and/or drives around */

	i = min (length (rtrim (tao.volname (1))), 32 - length (rtrim (module_name (standard))) - length ("_.cseg"));

	call hcs_$make_seg ("", module_name (standard) || substr (tao.volname (1), 1, i) /* make cseg */ || "_.cseg",
	     "", 01011b, cP, code);			/* or initiate if already exists */
	if cP = null then do;			/* no cseg made or found - fatal */
	     error_msg = "Unable to initiate/create temporary data segment.";
	     goto bad_attopt;
	end;

	if cseg.vcN > 0 then			/* already exists */
	     if cseg.vl (1).volname ^= tao.volname (1) then
						/* but not the right one */
		call hcs_$truncate_seg (cP, 0, code);	/* this is possible because we cannot use the */
						/* full name of the volume in the cseg name */

	if tao.clear_cseg then
	     call hcs_$truncate_seg (cP, 0, code);	/* re-do cseg */

	if cseg.vcN > 0 then do;			/* cseg previously existed */
	     if cseg.file_set_lock then do;		/* file set is locked */
		code = error_table_$file_busy;
		error_msg = "The file set is locked.";
		goto er_exit;
	     end;
	     else cseg.file_set_lock = "1"b;
	     code = 0;				/* not an error */
	     go to re_attach;			/* this is a re-attachment to the file set */
	end;

	cseg.file_set_lock = "1"b;			/* cseg made and locked */
	cseg.standard = standard;
	cseg.no_labels = tao.no_labels;
	cseg.module = module_name (standard);
	cseg.ndrives = 1;
	cseg.nactive = 0;
	cseg.vcN = 0;
	cseg.fcP = null;
	cseg.write_ring = tao.write_ring;
	cseg.protect = "0"b;
	cseg.density = tao.density;
	cseg.rlP = null;
	cseg.buf_size = blocksize;			/* set the tseg buffer size */
	call cseg_init;				/* initialize cseg with attach data */
	cseg.invalid = "0"b;			/* cseg is valid */

	call tape_ansi_tape_io_$attach (cP);		/* initialize IO */

	on area
	     begin;				/* shouldn't occur, but handle if does */
		code = error_table_$noalloc;
		go to er_exit;			/* cleanup is necessary */
	     end;
	area_size = sys_info$max_seg_size - size (cseg);
	call area_ (area_size, addr (cseg.chain_area));	/* format chain area for link allocation */
	allocate fd in (chain_area) set (cseg.fcP);	/* allocate the dummy file chain link */

	do i = 1 to tao.nvolumes;			/* build the volume chain */
	     call vl_init (i);			/* initialize all other values */
	     cseg.vcN = i;				/* set the new volume chain count */
	end;

	call tape_ansi_mount_cntl_$mount (cP, 1, code);	/* mount the volume on a new drive */
	if code ^= 0 then
	     go to er_exit;				/* success? */

	call fd_init;				/* initialize file data with attach and mount data */

attach_ok:
	cseg.attach_description.length = length (tstring);/* prepare attach description */
	cseg.attach_description.string = tstring;
	if tao.DOS then
	     cseg.standard = 3;			/* up standard for ibm_lrec_io_ */
	mask = "0"b;				/* IPS interrupts not masked yet */
	revert cleanup;				/* cleanup no longer matters */
	on any_other call handler;			/* pick up any condition */
	call hcs_$set_ips_mask ("0"b, mask);		/* mask all IPS interrupts */
	if cseg.no_labels then
	     iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_nl_file_cntl_$open;
	else iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_file_cntl_$open;
	iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_;
	iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_;
	iocbP -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = addr (cseg.attach_description);
	iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr = cP;
	call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
						/* reflect changes to all iocb's */
	call hcs_$reset_ips_mask (mask, mask);		/* permit IPS interrupts */
	return;

re_attach:
	if tao.density ^= -1 then
	     if tao.density ^= cseg.density then do;	/* density changed from previous attach */
		do i = 1 to cseg.vcN;		/* see if all volumes demounted */
		     if vl (i).rcp_id ^= 0 then do;	/* still mounted - can't change density */
			error_msg = "Cannot change file set density.";
bad_re_attach:
			code = error_table_$bad_arg;
			cseg.file_set_lock = "0"b;	/* unlock the file set */
			go to bad_attopt;
		     end;
		end;
		cseg.density = tao.density;		/* (re)set it */
	     end;

	if tao.no_labels ^= cseg.no_labels then do;	/* can't change label standard */
	     error_msg = "Cannot change label standard.";
	     go to bad_re_attach;
	end;

	if tao.ndrives = 0 then
	     go to chain_ck;			/* ndrives unspecified - maintain old value */
	if tao.ndrives >= cseg.ndrives then do;		/* necessary to free drives? */
	     cseg.ndrives = tao.ndrives;		/* no - set new value */
	     go to chain_ck;			/* check volume sequence validity */
	end;
	else cseg.ndrives = tao.ndrives;		/* yes - set new value */

	if cseg.nactive <= cseg.ndrives then
	     go to chain_ck;			/* not necessary to free any drives */
	else drop = cseg.nactive - cseg.ndrives;	/* drives must be freed */

/* scan file chain to find requested file */
	cseg.flP = cseg.fcP;			/* start with dummy link */
	if fd.nextP = null then
	     go to no_chain;			/* no file chain */
	do cseg.flP = fl.nextP repeat fl.nextP;		/* start with 1st real link */
	     if tao.sequence = 0 then do;		/* search for fileid */
		if tao.replace_id = fl.file_id then
		     go to got_fl;			/* match? */
		if tao.file_id = fl.file_id then
		     go to got_fl;			/* match? */
	     end;
	     else if tao.sequence = fl.sequence then
		go to got_fl;			/* search for sequence */
	     if fl.nextP = null then
		go to got_fl;			/* no more links - exit */
	     if fl.nextP -> fl.flX = -1 then
		go to got_fl;			/* stop before eofsl */
	end;

got_fl:
	do i = 1 to fl.vlX - 1;			/* search up to wanted volume */
	     if vl (i).rcp_id ^= 0 then do;		/* active - free it */
		call tape_ansi_mount_cntl_$free (cP, i, code);
		if code ^= 0 then
		     go to er_exit;			/* trouble */
		drop = drop - 1;
		if drop = 0 then
		     go to chain_ck;		/* done? */
	     end;
	end;

no_chain:
	do i = cseg.vcN to fl.vlX + 1 by -1;		/* search down to wanted volume */
	     if vl (i).rcp_id ^= 0 then do;		/* active - free it */
		call tape_ansi_mount_cntl_$free (cP, i, code);
		if code ^= 0 then
		     go to er_exit;			/* trouble */
		drop = drop - 1;
		if drop = 0 then
		     go to chain_ck;
	     end;
	end;

	code = error_table_$invalid_cseg;		/* this is very very bad */
	error_msg = "Control segment deleted.";
	go to er_exit;

chain_ck:
	if tao.nvolumes = 1 then
	     go to finish;				/* no follow-on volumes specified */
	do i = 2 to tao.nvolumes;			/* loop to check each follow-on volume */
	     if i > cseg.vcN then do;			/* links do not exist for the following volumes */
		do j = i to tao.nvolumes;		/* make a link for each new volume */
		     call vl_init (j);		/* initialize all other values */
		     cseg.vcN = j;			/* set the new volume chain count */
		end;
		go to finish;
	     end;
	     if vl (i).volname ^= tao.volname (i) then do;/* link exists - mismatch? */
		if vl (i).fflX ^= 0 then do;		/* this volume is a volume set member */
		     error_msg = "Invalid volume set sequence.";
		     code = error_table_$bad_arg;
		     cseg.file_set_lock = "0"b;	/* unlock the file set */
		     go to bad_attopt;
		end;
		else do;				/* this volume is a volume set candidate */
		     if vl (i).rcp_id ^= 0 then do;	/* mounted? */
			call tape_ansi_mount_cntl_$free (cP, i, code);
						/* free it */
			if code ^= 0 then
			     go to er_exit;
		     end;
		     call vl_init (i);		/* re-initialize the link */
		end;
	     end;
	end;

finish:
	if tao.write_ring then do;			/* user wants to write */
	     if ^cseg.write_ring then do;		/* but no rings are in the volumes */
		call tape_ansi_mount_cntl_$insert_rings (cP, code);
						/* so put them in */
		if code ^= 0 then
		     go to er_exit;
	     end;
	     if cseg.protect then do;			/* but hardware protect is on */
		call tape_ansi_mount_cntl_$write_permit (cP, code);
						/* so set hardware permit */
		if code ^= 0 then
		     go to er_exit;
	     end;
	end;

	else do;					/* user doesn't want to write */
	     if cseg.write_ring then do;		/* but rings are in */
		if ^cseg.protect then do;		/* and hardware protect is off */
		     call tape_ansi_mount_cntl_$write_protect (cP, code);
						/* so turn it on */
		     if code ^= 0 then
			go to er_exit;
		end;
	     end;
	end;

	call cseg_init;				/* fill cseg with attach data */
	call fd_init;				/* fill file data with attach data */
	go to attach_ok;

check_attopt:
     procedure (msg, ecode);				/* IO Module-specific attach option validation */

dcl      msg		  char (*) varying, 	/* erroneous option */
         ecode		  fixed bin (35);		/* error code */

dcl      ANSI		  char (18) internal static init ("ANSI standard and ");
dcl      IBM		  char (17) internal static init ("IBM standard and ");
dcl      NL		  char (17) internal static init ("""-no_labels"" and ");
dcl      NOUT		  char (22) internal static init (" and no output option.");

	msg = "";					/* initialize returned arguments */
	ecode = 0;

	if tao.ntracks = 0 then
	     tao.ntracks = 9;			/* default is 9 track drives */
	else if tao.ntracks ^= 9 then do;		/* ANSI doesn't support any other tracks */
	     msg = "Only ""-track 9"" is valid.";
	     go to bad;
	end;

	if tao.density = -1 then
	     ;					/* default is ok */
	else if tao.density = 2 then
	     ;					/* 800 bpi is ok */
	else if tao.density = 3 then
	     ;					/* 1600 bpi is ok */
	else if tao.density = 4 then
	     ;					/* 6250 bpi is ok */
	else do;					/* any other is invalid */
	     msg = "Invalid ""-density"" option.";
	     go to bad;
	end;


	if standard = 1 then do;			/* ANSI standard checks */
	     if tao.DOS then do;
		msg = ANSI || """-dos"".";
		go to bad;
	     end;
	     if tao.no_labels then do;
		msg = ANSI || """-no_labels"".";
		go to bad;
	     end;
	end;

	else do;					/* IBM standard checks */
	     if tao.output_mode = 3 then do;		/* -generate */
		msg = IBM || """-generate"".";
		go to bad;
	     end;
	     if tao.output_mode > 0 then do;		/* output option specified */
		if tao.blklen ^= 0 then do;		/* -block specified */
		     if mod (tao.blklen, 4) ^= 0 then do;
						/* blklen not word multiple */
			msg = """-block"" not multiple of 4.";
			go to bad;
		     end;
		end;
	     end;
	     if tao.no_labels then do;		/* -no_labels specified */
		if tao.DOS then do;			/* -dos specified */
		     msg = NL || """-dos"".";
		     go to bad1;
		end;
		if tao.file_id ^= "" then do;		/* -name specified */
		     msg = NL || """-name"".";
		     go to bad1;
		end;
		if tao.replace_id ^= "" then do;	/* -replace specified */
		     msg = NL || """-replace"".";
		     go to bad1;
		end;
		if tao.sequence = 0 then do;		/* no sequence specified */
		     msg = """-no_labels"" requires ""-number"".";
		     go to bad3;
		end;
		if tao.output_mode = 1 then do;	/* -extend specified */
		     msg = NL || """-extend"".";
		     go to bad1;
		end;
		else if tao.output_mode = 2 then do;	/* -modify specified */
		     msg = NL || """-modify"".";
		     go to bad1;
		end;
		if tao.expiration ^= "00000" then do;	/* -expires specified */
		     msg = NL || """-expires"".";
		     go to bad1;
		end;
		if tao.force then do;		/* -force specified */
		     msg = NL || """-force"".";
		     go to bad1;
		end;
		go to format_ck;
	     end;
	end;

	if tao.output_mode = 4 then do;		/* ANSI and IBM checks  -  create */
	     if tao.file_id = "" then do;		/* no -name */
		msg = """-create"" requires ""-name"".";
		go to bad3;
	     end;
	     if standard = 2 then do;			/* validate file id if IBM */
		temp_file_name = tao.file_id;
		msg = "Invalid ""-name"" identifier.";

		do while (temp_file_name ^= "");
		     part_file_name = rtrim (before (temp_file_name, "."));
		     temp_file_name = after (temp_file_name, ".");
		     if length (part_file_name) = 0 then
			goto bad;			/* must have name! */
		     if length (part_file_name) > 8 then
			goto bad;			/* no component can be > 8 chars */
		     if index (ibm_verify1, substr (part_file_name, 1, 1)) = 0 then
			goto bad;			/* first char must be from limited set */
		     if verify (part_file_name, string (ibm_verifies)) > 0 then
			goto bad;			/* all chars must be from certain set */
		end;

		msg = "";
	     end;
	end;
	else do;					/* extend, modify, generate, or none */
	     if tao.replace_id ^= "" then do;		/* -replace specified */
		msg = """-replace"" requires ""-create"".";
		go to bad3;
	     end;
	     else if tao.output_mode = 0 then do;	/* none specelse ified */
		if tao.expiration ^= "00000" then do;
		     msg = """-expires""" || NOUT;
		     go to bad3;
		end;
		if tao.force then do;
		     msg = """-force""" || NOUT;
		     go to bad3;
		end;
	     end;
	     else if tao.output_mode < 3 then do;	/* output mode is extend or modify */
		if tao.expiration ^= "00000" then do;	/* and expiration specified */
		     if tao.output_mode = 1 then
			msg = """-extend"" and ""-expires"".";
		     else msg = """-modify"" and ""-expires"".";
		     go to bad1;
		end;
	     end;
	end;

	if tao.sequence = 0 then do;			/* no explicit sequence */
	     if tao.file_id = "" then do;		/* and no -name */
		msg = """-name"" or ""-number"" needed.";
		go to bad3;
	     end;
	end;

format_ck:
	if tao.format = "" then do;			/* default format */
	     format_code = 0;
	     go to test (0);
	end;
	do i = 1 to 7;				/* validate format */
	     if tao.format = format.type (standard, i) then do;
						/* match? */
		format_code = format.fcode (standard, i);
		block_attribute = format.blkatrib (standard, i);
		go to test (format_code);
	     end;
	end;
	msg = "Unsupported ""-format"" option.";
	go to bad;

test (1):
	if tao.reclen ^= 0 then do;			/* u format */
	     msg = """-record"" and ""-format"".";
	     go to bad1;
	end;
	go to test (0);
test (2):
	if tao.blklen ^= 0 then do;			/* f format */
	     if tao.reclen ^= 0 then do;
		if block_attribute then do;
		     if mod (tao.blklen, tao.reclen) ^= 0 then do;
br_inc:
			msg = """-block"" and ""-record"".";
			go to bad1;
		     end;
		end;
		else if tao.blklen ^= tao.reclen then
		     go to br_inc;
	     end;
	end;
	go to test (0);
test (3):
	if tao.blklen ^= 0 then
	     if tao.reclen ^= 0 then do;		/* d/v format */
		if standard = 1 then
		     i = 0;			/* don't allow for BDW if ANSI */
		else i = 4;			/* IBM - allow for 4 byte BDW */
		if block_attribute then do;
		     if tao.blklen < tao.reclen + i then
			go to br_inc;
		end;
		else if tao.blklen ^= tao.reclen + i then
		     go to br_inc;
	     end;
test (0):
test (4):
	tstring = module_name (standard);		/* initialize attach description with module name */
	do i = 1 to tao.noptions;			/* append each option */
	     tstring = tstring || " " || options (i);
	end;
	return;

bad:
	ecode = error_table_$bad_arg;
	return;
bad1:
	ecode = error_table_$inconsistent;
	return;
bad3:
	code = error_table_$noarg;
	return;

     end check_attopt;

tao_init:
     procedure;					/* initialize attach options */

	tao.noptions, tao.ntracks, tao.retain, tao.output_mode, tao.sequence, tao.blklen, tao.reclen, tao.mode,
	     tao.nvolumes, tao.ndrives = 0;

	tao.density = -1;

	tao.write_ring, tao.clear_cseg, tao.force, tao.user_labels, tao.DOS, tao.no_labels = "0"b;

	tao.format, tao.replace_id, tao.file_id, tao.volname (*), tao.comment (*) = "";

	tao.expiration = "00000";

	return;

     end tao_init;

cseg_init:
     procedure;					/* initializes cseg with attach data */
	cseg.flP = null;
	cseg.open_mode = 0;
	cseg.force = tao.force;
	cseg.file_lock = "0"b;
	cseg.close_rewind = "0"b;
	cseg.user_labels = tao.user_labels;
	cseg.output_mode = tao.output_mode;
	cseg.replace_id = tao.replace_id;
	cseg.retain = tao.retain;
	if tao.ndrives ^= 0 then
	     cseg.ndrives = tao.ndrives;		/* set ndrives only if specified */
	cseg.rlN = -1;
	cseg.user_label_routine (*) = tape_ansi_attach_$no_user_routine;
	return;
     end cseg_init;

fd_init:
     procedure;					/* initializes file data with attach and mount data */
	fd.hdr1.file_id = tao.file_id;
	fd.hdr1.set_id = vl (1).volname;
	fd.hdr1.canonical_set_id = vl (1).canonical_volname;
	fd.hdr1.sequence = tao.sequence;
	fd.hdr1.creation = today ();
	fd.hdr1.expiration = tao.expiration;
	if standard = 1 then
	     fd.access = " ";
	else fd.access = "0";
	fd.hdr1.system = system_code (standard);
	fd.hdr2.format = format_code;
	fd.hdr2.blocked = block_attribute;
	fd.hdr2.blklen = tao.blklen;
	fd.hdr2.reclen = tao.reclen;
	fd.hdr2.mode = tao.mode;
	fd.hdr2.bo = 0;
	fd.cc = " ";
     end fd_init;


vl_init:
     procedure (n);					/* initialize a volume link */
dcl      n		  fixed bin;		/* link index */
dcl      canon_std		  (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);

	vl (n).volname = tao.volname (n);
	vl (n).comment = tao.comment (n);
	vl (n).fflX = 0;
	vl (n).cflX = 0;
	vl (n).pos = 0;
	vl (n).lflX = 0;
	vl (n).tracks = 0;
	vl (n).density = 0;
	vl (n).label_type = 0;
	vl (n).usage_count = 0;
	vl (n).read_errors = 0;
	vl (n).write_errors = 0;
	vl (n).rcp_id = 0;
	vl (n).event_chan = 0;
	vl (n).tape_drive = "";
	vl (n).write_VOL1 = 0;
	vl (n).ioi_index = 0;
	call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (n).volname, vl (n).canonical_volname,
	     canon_std (standard), code);
	if code ^= 0 then do;
	     error_msg = tao.volname (1);
	     goto bad_attopt;
	end;

	return;
     end vl_init;

er_exit:
	if comerr then
	     call com_err_ (code, module_name (standard), "^a", error_msg);
	call cleaner;
	return;


handler:
     procedure;					/* intercept any faults during iocb manipulation */
dcl      1 ti		  aligned,
	 2 version	  fixed bin init (0),
	 2 code		  fixed bin (35);

	if mask ^= "0"b then do;			/* IPS interrupts masked */
	     ti.code = error_table_$unable_to_do_io;	/* very bad trouble */
	     call terminate_process_ ("fatal_error", addr (ti));
						/* kill the process */
	end;
	call continue_to_signal_ (0);
	return;
     end handler;


cleaner:
     procedure;					/* tidy up if bad trouble */
	if cP ^= null then do;			/* cseg exixts */
	     do i = 1 to cseg.vcN;			/* check every link, if any */
		if vl (i).rcp_id ^= 0 then
		     call tape_ansi_mount_cntl_$free (cP, i, 0);
						/* active */
	     end;
	     call hcs_$delentry_seg (cP, 0);		/* delete cseg */
	end;
     end cleaner;


today:
     procedure returns (char (5));			/* returns today's date in Julian form */
dcl      clock		  fixed bin (71),		/* holds hardware clock value */
         ddd		  picture "999",		/* day of year */
         yy		  picture "99",		/* year */
         temp		  fixed bin;		/* temporary */

	clock = clock_ ();				/* get hardware clock value */
	call datebin_$dayr_clk (clock, temp);		/* get day of year */
	ddd = temp;				/* convert to characters */
	call datebin_ (clock, 0, 0, 0, temp, 0, 0, 0, 0, 0);
						/* get year */
	yy = temp - 1900;				/* drop century and convert to characters */
	return (yy || ddd);				/* return formatted date */

     end today;

no_user_routine:
     entry;					/* dummy entry point to indicate no user label routine */




     end tape_ansi_attach_;




		    tape_ansi_control_.pl1          11/04/82  1931.3rew 11/04/82  1606.0      209394



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





tape_ansi_control_: procedure (iocbP, order, infoP, code);	/* performs iox_$control function for tape_ansi_ */


/* Modified 08/17/76 by Janice Phillipps to handle io_call order requests.  */
/* Modified 12/18/78 by Michael R. Jordan to add volume_density order as a
   temporary measure for list_tape_contents.  */
/* Modified 04/11/79 by C. D. Tavares for resource management */
/* Modified 08/81 by M. R. Jordan for bug fixes */

/* arguments */
	dcl     iocbP		 ptr,		/* pointer to iocb */
	        order		 char (*),	/* control order name */
	        infoP		 ptr,		/* pointer to information structure */
	        code		 fixed bin (35);	/* error code */

/* based storage */

	dcl     hardware_status	 bit (72) aligned based (infoP); /* information for "hardware_status" order */
	dcl     retain_code		 fixed bin based (infoP); /* information for "retention" */



/* automatic storage */

	dcl     ret_code		 fixed bin (35);
	dcl     io_order		 char (32) varying;
	dcl     volume_density_ptr	 ptr;
	dcl     volume_density	 fixed bin based (volume_density_ptr);

	dcl     file_status_sw	 bit (1);
	dcl     msg_sw		 bit (1);
	dcl     state		 fixed bin;
	dcl     event_code		 fixed bin (35);
	dcl     lbl		 bit (1) aligned;

	dcl     errmsg		 char (64) aligned;
	dcl     short		 char (8) aligned;
	dcl     long		 char (100) aligned;
	dcl     i			 fixed bin;	/* temporary */
	dcl     io_mod		 fixed bin;


/* internal static */

	dcl     central_msg		 (0:7) char (55) internal static options (constant) init (
				 """000""b",
				 "LPW tally runout",
				 "two sequential TDCW's",
				 "boundary violation",
				 "invalid IOM central status - ""100""b",
				 "IDCW in restricted mode",
				 "character position/size discrepancy during list service",
				 "parity error on I/O bus, data read from channel"),
	        channel_msg		 (0:7) char (46) int static options (constant) init (
				 """000""b",
				 "attempt to connect while busy",
				 "illegal channel command in PCW",
				 "incorrect DCW during list service",
				 "incomplete instruction sequence",
				 "invalid channel status - ""101""b",
				 "parity error on PSIA",
				 "parity error on I/O bus, data write to channel"),
	        format		 (2, 8) char (3) int static options (constant) init (
				 "u", "f", "d", "s", "ub", "fb", "db", "sb",
				 "u", "f", "v", "vs", "ub", "fb", "vb", "vbs"),
	        mode		 (3) char (6) int static options (constant) init (
				 "ASCII", "EBCDIC", "binary"),
	        State		 (0:3) char (32) int static options (constant) init (
				 "no information", "not open", "open", "open, but further I/O inhibited");

	dcl     1 order_list	 (12) internal static options (constant), /* list of valid control orders */
		2 name		 char (32) varying init (/* orders */
				 "hardware_status",
				 "status",
				 "volume_status",
				 "feov",
				 "close_rewind",
				 "retention",
				 "file_status",
				 "retain_none",
				 "retain_all",
				 "reset_error_lock",
				 "volume_density",	/* temp for MR7.0 for list_tape_contents */
				 "io_call"),
		2 must_be_open	 bit (1) init ("1"b, "1"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b),
		2 non_null_ptr	 bit (1) init ("1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b);

	dcl     1 io_order_list	 (10) internal static options (constant), /* list of valid control orders foor use thru io_call */
		2 long_name	 char (32) varying init (/* orders */
				 "hardware_status",
				 "status",
				 "volume_status",
				 "feov",
				 "close_rewind",
				 "retention",
				 "file_status",
				 "retain_none",
				 "retain_all",
				 "reset_error_lock"),
		2 short_name	 char (4) varying init (/* orders */
				 "hst",
				 "st",
				 "vst",
				 "feov",
				 "crw",
				 "ret",
				 "fst",
				 "retn",
				 "reta",
				 "rel"),
		2 must_be_open	 bit (1) init ("1"b, "1"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b),
		2 arguments	 bit (1) init ("0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b);


	dcl     1 io_order_user_msg	 (10) internal static options (constant), /* list of valid order request syntax */
		2 msgs		 char (48) varying init (/* orders */
				 "hardware_status",
				 "status {-all}",
				 "volume_status",
				 "feov",
				 "close_rewind",
				 "retention -all | -volume | -device | -none",
				 "file_status",
				 "retain_none",
				 "retain_all",
				 "reset_error_lock");

/* external procedures */

	dcl     tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35));
	dcl     convert_status_code_	 entry (fixed bin (35), char (8) aligned, char (100) aligned);
	dcl     tape_ansi_nl_file_cntl_$data_eot ext entry (ptr, fixed bin (35));

/* external static */

	dcl     (error_table_$action_not_performed,
	        error_table_$wrong_no_of_args,
	        error_table_$bad_arg,
	        error_table_$undefined_order_request,
	        error_table_$file_busy,
	        error_table_$invalid_cseg,
	        error_table_$no_operation,
	        error_table_$no_next_volume,
	        error_table_$not_open,
	        error_table_$tape_error) fixed bin (35) external static;

/* conditions and builtins */

	dcl     cleanup		 condition,
	        (hbound, null, addr, binary, convert, substr) builtin;
%page;
%include iocb;
%page;
%include tape_ansi_cseg;
%page;
%include tape_ansi_fd;
%page;
%include tape_ansi_fl;
%page;
%include tape_file_status;
%page;
%include tape_volume_status;
%page;
%include device_status;
%page;
%include iom_stat;
%page;
%include io_call_info;
%page;
	do i = 1 to hbound (order_list, 1);		/* determine which order to execute */
	     if order = order_list.name (i) then do;	/* got it - now check it */
		     if order_list.must_be_open (i) then do;
			     if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null () then do;
				     code = error_table_$not_open;
				     return;
				end;
			end;
		     if order_list.non_null_ptr (i) then do;
			     if infoP = null then do;
				     code = error_table_$bad_arg;
				     return;
				end;
			end;
		     go to START;
		end;
	end;
	code = error_table_$no_operation;		/* invalid order */
	return;


START:	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* all ok - get cseg pointer */

	if cseg.invalid then do;
		code = error_table_$invalid_cseg;
		return;
	     end;

	if cseg.file_lock then do;
		code = error_table_$file_busy;
		return;
	     end;
	else do;
		on cleanup cseg.file_lock = "0"b;
		cseg.file_lock = "1"b;
	     end;

	code = 0;					/* initialize error code */
	go to act (i);				/* transfer to perform appropriate processing */
%page;
act (1):						/* hardware_status */

	hardware_status = cseg.hdw_status.bits;		/* give 72 bit IOM status */
	go to exit;
%skip (5);
act (2):						/* status */

	dstat_ptr = infoP;				/* set pointer to structure */
	device_status = cseg.hdw_status;		/* give entire status structure */
	go to exit;
%skip (5);
act (3):						/* volume_status */

	tvstat_ptr = infoP;				/* set pointer to structure */
	call setup_for_vol_status;

	tape_volume_status.volume_name = vl (i).canonical_volname; /* fill status structure */
	tape_volume_status.volume_id = substr (vl (i).volname, 1, 6);
	tape_volume_status.volume_seq = i;
	if vl (i).rcp_id = 0 then tape_volume_status.tape_drive = "";
	else tape_volume_status.tape_drive = vl (i).tape_drive;
	tape_volume_status.read_errors = vl (i).read_errors;
	tape_volume_status.write_errors = vl (i).write_errors;
	go to exit;
%page;
act (4):						/* feov */

	if cseg.open_mode ^= 5 then do;		/* opening must be sequential_output */
		code = error_table_$action_not_performed;
		go to exit;
	     end;

	call force_eov;
	go to exit;
%skip (5);
act (5):						/* close_rewind */

	cseg.close_rewind = "1"b;			/* set the switch for next close operation */
	go to exit;
%skip (5);
act (6):						/* retention */

	if retain_code < 0 | retain_code > 4 then do;	/* check validity */
		code = error_table_$bad_arg;
		go to exit;
	     end;

	cseg.retain = retain_code;			/* set the new retention */
	go to exit;
%page;
act (7):						/* file_status */

	tfstat_ptr = infoP;				/* set pointer to structure */
	call setup_for_file_status;			/* sets state and event code */

	tape_file_status.state = state;
	tape_file_status.event_code = event_code;

	if cseg.no_labels then do;			/* no file chain */
		tape_file_status.file_id = "";
		tape_file_status.file_seq = fd.sequence;
		tape_file_status.cur_section = fd.vlX;
		tape_file_status.cur_volume = vl (fd.vlX).canonical_volname;
		tape_file_status.generation = 0;
		tape_file_status.version = 0;
		tape_file_status.creation = "00000";
		tape_file_status.expiration = "00000";
		tape_file_status.format_code = fd.format;
		tape_file_status.blklen = fd.blklen;
		tape_file_status.reclen = fd.reclen;
		tape_file_status.blocked = fd.blocked;
		tape_file_status.mode = fd.mode;
	     end;
	else do;					/* file chain exists */
		tape_file_status.file_id = fl.file_id;
		tape_file_status.file_seq = fl.sequence;
		tape_file_status.cur_section = fl.section;
		tape_file_status.cur_volume = vl (fl.vlX).canonical_volname;
		tape_file_status.generation = fl.generation;
		tape_file_status.version = fl.version;
		tape_file_status.creation = fl.creation;
		tape_file_status.expiration = fl.expiration;
		tape_file_status.format_code = fl.format;
		tape_file_status.blklen = fl.blklen;
		tape_file_status.reclen = fl.reclen;
		tape_file_status.blocked = fl.blocked;
		tape_file_status.mode = fl.mode;
	     end;

	tape_file_status.cur_blkcnt = cseg.lrec.blkcnt;
	go to exit;
%page;
act (8):						/* retain_none */

	cseg.retain = 1;
	go to exit;
%skip (5);
act (9):						/* retain_all */

	cseg.retain = 4;
	go to exit;
%skip (5);
act (10):						/* reset_error_lock */

	call reset_error_lock;
	go to exit;
%skip (5);
act (11):						/* volume_density temp for ltc */

	volume_density_ptr = infoP;			/* set pointer to variable */
	volume_density = cseg.density;		/* copy info */
	goto exit;
%page;
act (12):						/* io_call orders */

	io_call_infop = infoP;

	if cseg.standard = 1 then io_mod = 1;		/* tape_ansi_ io mod */
	else io_mod = 2;				/* tape_ibm_ io mod */

	do i = 1 to hbound (io_order_list, 1);		/* determine which order to execute */
	     io_order = io_call_info.order_name;
	     if io_order = io_order_list.long_name (i) |
		io_order = io_order_list.short_name (i) then do; /* got it - now check it */
		     if io_order_list.must_be_open (i) then do;
			     if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null () then do;
				     call io_call_info.error (error_table_$not_open,
					io_call_info.caller_name,
					"^/The ^a control operation requires that the I/O switch be open.",
					io_order_list.long_name (i));
				     go to exit;
				end;
			end;
		     if io_call_info.nargs > 0 then do; /* some orders take args */
			     if io_order_list.arguments (i) then do;
				     if io_call_info.nargs = 1 then ;
				     else do;
wrong_no_args:				     call io_call_info.error (error_table_$wrong_no_of_args,
						io_call_info.caller_name,
						"^/Usage: io control SWITCH ^a",
						io_order_user_msg.msgs (i));
					     go to exit;
					end;
				end;
			     else go to wrong_no_args;
			end;
		     go to ord (i);

		end;
	end;

	call io_call_info.error (error_table_$undefined_order_request, io_call_info.caller_name, "^a", io_order);
	go to exit;
%page;
ord (1):						/* hardware_status call */

	call print_hardware_status;
	go to exit;
%skip (5);
ord (2):						/* status order call */

	if io_call_info.nargs = 0 then do;
		file_status_sw = "0"b;
		call print_device_status;
	     end;
	else if io_call_info.args (1) = "-all"
		| io_call_info.args (1) = "-a" then do;
		file_status_sw = "1"b;
		call print_device_status;
		call print_hardware_status;
		call setup_for_vol_status;
		call print_volume_status;
		call setup_for_file_status;
		call print_file_status;
	     end;
	else do;
		call io_call_info.error (error_table_$bad_arg,
		     io_call_info.caller_name,
		     "^a^/Usage: io control SWITCH ^a",
		     io_call_info.args (1),
		     io_order_user_msg.msgs (i));
		go to exit;
	     end;

	go to exit;
%skip (5);
ord (3):						/* volume_status order call */

	call setup_for_vol_status;
	call print_volume_status;
	go to exit;
%skip (5);
ord (4):						/* feov order call */

	if cseg.open_mode ^= 5 then do;
		call io_call_info.error (error_table_$action_not_performed,
		     io_call_info.caller_name,
		     "^/I/O switch must be open for sequential_output.");
	     end;
	else do;
		call force_eov;
		if code ^= 0 then
		     call io_call_info.error (code,
			io_call_info.caller_name,
			"^/Unable to force volume switching.");
	     end;
	go to exit;
%skip (5);
ord (5):						/* close_rewind order call */

	cseg.close_rewind = "1"b;
	go to exit;
%skip (5);
ord (6):						/* retention order call */

	if io_call_info.nargs = 0
	then goto wrong_no_args;

	if io_call_info.args (1) = "-all"
	     | io_call_info.args (1) = "-a"
	then ret_code = 4;
	else if io_call_info.args (1) = "-none"
	then ret_code = 1;
	else if io_call_info.args (1) = "-volume"
		| io_call_info.args (1) = "-vol"
	then ret_code = 2;
	else if io_call_info.args (1) = "-device"
		| io_call_info.args (1) = "-dv"
	then ret_code = 3;
	else do;
bad_arg:		call io_call_info.error (error_table_$bad_arg,
		     io_call_info.caller_name,
		     "^/Bad retention specification.  ^a",
		     io_call_info.args (1));
		go to exit;
	     end;

	cseg.retain = ret_code;			/* set the new retention */
	go to exit;
%skip (5);
ord (7):						/* file_status order call */

	call setup_for_file_status;
	if cseg.no_labels
	then call print_nl_file_status ();
	else call print_file_status ();
	go to exit;
%skip (5);
ord (8):						/* retain_none order call */

	cseg.retain = 1;
	go to exit;
%skip (5);
ord (9):						/* retain_all order call */

	cseg.retain = 4;
	go to exit;
%skip (5);
ord (10):						/* reset_error_lock order call */

	call reset_error_lock;
	if code ^= 0 then
	     call io_call_info.error (code,
		io_call_info.caller_name,
		"^/Unable to reset lock.  I/O switch must be open for sequential_input.");
%skip (5);
exit:	cseg.file_lock = "0"b;
	return;
%page;
print_hardware_status: procedure;

	statp = addr (cseg.hdw_status.bits);		/* set ptr to status structure */
	if status.power then errmsg = "off or device disconnected";
	else errmsg = "on";
	call io_call_info.report ("Power:^2-^a", errmsg);
	call io_call_info.report ("Major status:^-""^4b""b", status.major);
	call io_call_info.report ("Substatus:^-""^6b""b", status.sub);
	call io_call_info.report ("Even/Odd:^2-""^1b""b", status.eo);
	if status.marker then errmsg = "yes";
	else errmsg = "no, terminate status";
	call io_call_info.report ("Marker status:^-^a", errmsg);
	call io_call_info.report ("Software status:^-""^2b""b", status.soft);
	call io_call_info.report ("Initiate:^2-""^1b""b", status.initiate);
	call io_call_info.report ("Software abort:^-""^1b""b", status.abort);
	call io_call_info.report ("IOM channel:^-^a", channel_msg (binary (status.channel_stat)));
	call io_call_info.report ("IOM central:^-^a", central_msg (binary (status.central_stat)));
	call io_call_info.report ("Rec count residue:^-^d (decimal)", binary (status.rcount));
	call io_call_info.report ("DCW address:^-^6w (octal)", binary (status.address), 35);
	call io_call_info.report ("Character position:^-^d (decimal)", binary (status.char_pos));
	if status.r then errmsg = "yes";
	else errmsg = "no";
	call io_call_info.report ("Reading:^2-^a", errmsg);
	call io_call_info.report ("Last DCW type:^-""^2b""b", status.type);
	call io_call_info.report ("DCW tally:^-^d (decimal)^/", binary (status.tally));
	return;

     end print_hardware_status;
%page;
print_device_status: procedure;

	errmsg = "Device status";
	if cseg.hdw_status.no_minor = 0 then do;	/* no minor status entered */
		call convert_status_code_ (cseg.hdw_status.major, short, long);
		call io_call_info.report ("^a:^-^a", errmsg, long);
	     end;
	else do i = 1 to cseg.hdw_status.no_minor;
		call convert_status_code_ (cseg.hdw_status.minor (i), short, long);
		call io_call_info.report ("^a:^-^a", errmsg, long);
		errmsg = "       and:";
	     end;
	if ^file_status_sw then /* only for not file_status */
	     call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt);
	else call io_call_info.report ("");
	return;

     end print_device_status;
%page;
print_volume_status: procedure;

/* prints info from cseg: i = current volume number of volume set. */

	call io_call_info.report ("Volume name:^-^a", vl (i).volname);
	call io_call_info.report ("Label ID:^-^a", vl (i).canonical_volname);
	call io_call_info.report ("Volume sequence no:^-^d", i);
	if vl (i).rcp_id = 0 then
	     call io_call_info.report ("Tape drive:^-(Volume Not Mounted)");
	else call io_call_info.report ("Tape drive:^-^a", vl (i).tape_drive);
	if vl (i).read_errors > 0 then
	     call io_call_info.report ("Read errors:^-^d", vl (i).read_errors);
	if vl (i).write_errors > 0 then
	     call io_call_info.report ("Write errors:^-^d", vl (i).write_errors);
	call io_call_info.report ("");
	return;

     end print_volume_status;
%page;
print_file_status: procedure;


	call io_call_info.report ("File state:^-^a", State (state));
	if state = 0 then do;
		call io_call_info.report ("");
		return;
	     end;
	if state = 3 then do;
		call convert_status_code_ (cseg.lrec.code, short, long);
		call io_call_info.report ("I/O inhibited because:^-^a", long);
	     end;
	call io_call_info.report ("File name:^-^a", fl.file_id);
	call io_call_info.report ("File number:^-^d", fl.sequence);
	call io_call_info.report ("File section no:^-^d", fl.section);
	call io_call_info.report ("Current volume:^-^a", vl (fl.vlX).canonical_volname);
	call io_call_info.report ("File generation:^-^d", fl.generation);
	call io_call_info.report ("File version:^-^d", fl.version);
	if fl.creation ^= "00000" then
	     call io_call_info.report ("Created on:^-^a", cv_date ((fl.creation)));
	if fl.expiration ^= "00000" then
	     call io_call_info.report ("Expires on:^-^a", cv_date ((fl.expiration)));
	call io_call_info.report ("Format:^2-^a", format (io_mod, fl.format
	     + (binary (fl.blocked, 1) * 4)));
	if fl.format ^= 1 then
	     call io_call_info.report ("Record length:^-^d", fl.reclen);
	call io_call_info.report ("Block length:^-^d", fl.blklen);
	call io_call_info.report ("Encoding mode:^-^a", mode (fl.mode));
	call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt);
	return;

     end print_file_status;
%page;
print_nl_file_status: procedure;


	call io_call_info.report ("File state:^-^a", State (state));
	if state = 0 then do;
		call io_call_info.report ("");
		return;
	     end;
	if state = 3 then do;
		call convert_status_code_ (cseg.lrec.code, short, long);
		call io_call_info.report ("I/O inhibited because:^-^a", long);
	     end;
	call io_call_info.report ("File number:^-^d", fd.sequence);
	call io_call_info.report ("File section no:^-^d", fd.vlX);
	call io_call_info.report ("Current volume:^-^a", vl (fd.vlX).canonical_volname);
	call io_call_info.report ("Format:^2-^a", format (io_mod, fd.format
	     + (binary (fd.blocked, 1) * 4)));
	if fd.format ^= 1 then
	     call io_call_info.report ("Record length:^-^d", fd.reclen);
	call io_call_info.report ("Block length:^-^d", fd.blklen);
	call io_call_info.report ("Encoding mode:^-^a", mode (fd.mode));
	call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt);
	return;

     end print_nl_file_status;
%page;
cv_date: proc (julian) returns (char (10) aligned);

	dcl     julian		 char (5);	/* date in form: yyddd			*/

	dcl     clock		 fixed bin (71),
	        (month, day, year)	 fixed bin,
	        (Cmonth, Cday, Cyear)	 pic "99",
	        date_time		 char (10) aligned,
	        code		 fixed bin (35);

	dcl     decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
				 fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)),
	        encode_clock_value_$offsets entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
				 fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (71), fixed bin (35));

	year = convert (year, substr (julian, 1, 2));
	day = convert (day, substr (julian, 3, 3));
	call encode_clock_value_$offsets (0, 0, day - 1, year - 1, 0, 0, 0, 0, 0, "gmt", clock, code);
	if code ^= 0 then return ("unknown");
	call decode_clock_value_$date_time (clock, month, day, year, 0, 0, 0, 0, 0, "gmt", code);
	if code ^= 0 then return ("unknown");
	Cmonth = month;
	Cday = day;
	Cyear = year - 1900;
	date_time = Cmonth || "/" || Cday || "/" || Cyear;
	return (date_time);

     end cv_date;
%page;
setup_for_vol_status: procedure;

	if cseg.no_labels then do;			/* no file chain */
		if fd.vlX = 0 then i = 1;		/* file data not initializeed - use 1st volume */
		else i = fd.vlX;
	     end;
	else do;
		if cseg.flP = cseg.fcP | cseg.flP = null then i = 1; /* no file links - use 1st volume */
		else i = fl.vlX;			/* else use current volume */
	     end;
	return;					/* i = number of current volume */

     end setup_for_vol_status;
%skip (10);
force_eov: procedure;


	code = 0;
	if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eot (iocbP, code);
	else call tape_ansi_file_cntl_$data_eot (iocbP, code); /* force volume switch */
	if code ^= 0 then do;			/* trouble */
		cseg.lrec.code = code;		/* lock the logical record IO */
		if code = error_table_$no_next_volume then code = 0; /* don't indicate now */
	     end;
	return;

     end force_eov;
%page;
setup_for_file_status: procedure;			/* determine file state and event code */

	code = 0;
	if cseg.no_labels then do;			/* no file chain */
		if fd.vlX = 0 then go to no_info;	/* no information available */
		else ;
	     end;
	else do;
		if cseg.flP = cseg.fcP | cseg.flP = null then do; /* no file links */
no_info:			state = 0;
			return;
		     end;
		if fl.file_id ^= fd.file_id & fl.sequence ^= fd.sequence then go to no_info; /* wrong link */
	     end;

	if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null then state = 1;
	else do;					/* file is open */
		event_code = cseg.lrec.code;		/* set event code */
		if cseg.lrec.code = 0 then state = 2;	/* no event */
		else state = 3;
	     end;
	return;

     end setup_for_file_status;
%page;
reset_error_lock: procedure;

	code = 0;
	if cseg.open_mode = 4 then do;		/* switch must be open for sequential_input */
		if cseg.lrec.code = error_table_$tape_error then cseg.lrec.code = 0; /* unlock the lock */
		if cseg.lrec.code = 0 then return;	/* lock isn't (or wasn't) locked - we're done */
	     end;
	code = error_table_$action_not_performed;	/* sequential_output or couldn't unlock */
	return;

     end reset_error_lock;


     end tape_ansi_control_;




		    tape_ansi_detach_.pl1           11/04/82  1931.3rew 11/04/82  1606.0       56430



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

/*                                                        */
/* 1) Modified: 06/29/79 by Rick Riley                    */
/*              (modify nonlabeled volume reporting)      */

tape_ansi_detach_: procedure (iocbP, code);		/* iox_$tape_ansi_detach_iocb entry point */

dcl  iocbP ptr,					/* pointer to iocb */
     code fixed bin (35);				/* error code */


%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;


/* automatic storage */
dcl  i fixed bin,					/* temporary volume chain index */
    (j, k) fixed bin,				/* message temporaries */
     mask bit (36) aligned,				/* ips interrupt mask */
     string char (96) varying;			/* volume set string */

/* builtin functions and conditions */
dcl (addr, max, null) builtin,
    (any_other, cleanup) condition;

/* error codes */
dcl (error_table_$file_busy,
     error_table_$unable_to_do_io) ext static fixed bin (35);

/* external procedures */
dcl  continue_to_signal_ ext entry (fixed bin (35)),
     hcs_$delentry_seg ext entry (ptr, fixed bin (35)),
     hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned),
     hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned),
     hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
     hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin (35)),
     ioa_ ext entry options (variable),
     iox_$propagate ext entry (ptr),
     tape_ansi_mount_cntl_$free ext entry (ptr, fixed bin, fixed bin (35)),
     terminate_process_ ext entry (char (*), ptr);

	code = 0;

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */

	if cseg.file_lock then do;			/* file in use? */
	     code = error_table_$file_busy;
	     return;
	end;
	else do;
	     on cleanup begin;
		if cP = null then go to force_detach;	/* no more cseg - detach iocb */
		else go to action (1);		/* eliminate drives and volumes */
	     end;
	     cseg.file_lock = "1"b;
	end;

	go to action (cseg.retain);			/* perform appropriate detach retention */

action (0):					/* CODE WHEN rcp_ IS USED */
action (1):					/* retain none */
	cseg.write_ring = "0"b;			/* no rings */
	cseg.protect = "0"b;			/* no hardware protection */
	do i = 1 to cseg.vcN;			/* test every volume link */
	     if vl (i).rcp_id ^= 0 then do;		/* active */
		vl (i).cflX = 0;			/* invalidate position info */
		call tape_ansi_mount_cntl_$free (cP, i, code); /* unassign drive and volume */
		if code ^= 0 then cseg.invalid = "1"b;	/* invalidate control segment */
	     end;
	end;
	go to detach_exit;

action (2):					/* retain devices */
	cseg.write_ring = "0"b;			/* no rings */
	cseg.protect = "0"b;			/* no hardware protect (loading will cancel) */
	go to action (1);				/* VERSION ONE TEMPORARY */

action (3):					/* retain volumes */
	cseg.write_ring = "0"b;			/* no rings */
	cseg.protect = "0"b;			/* no hardware protect */
	go to action (1);				/* VERSION ONE TEMPORARY */

action (4):					/* retain all */
	if cseg.invalid then go to action (1);		/* retain none if invalid control segment */

detach_exit: if cseg.rlP ^= null then do;
	     call hcs_$truncate_seg (cseg.rlP, 0, 0);
	     cseg.rlN = -1;
	end;

	if cseg.invalid then do;			/* cseg is invalid */
	     if cseg.rlP ^= null then do;		/* if read length segment exists */
		call hcs_$delentry_seg (cseg.rlP, 0);	/* delete it */
		cseg.rlP = null;			/* and null ptr to avoid problems */
	     end;
	     call hcs_$delentry_seg (cP, 0);		/* delete cseg */
	     cP = null;
	end;
	else if cseg.retain < 3 then do;		/* cseg valid - not retaining volumes */
	     if cseg.write_ring then do;		/* if volume set could have changed */

		if vl (cseg.vcN).fflX ^= 0 then go to force_detach; /* volume set is all volumes */

		do i = 1 to cseg.vcN while (vl (i).fflX ^= 0); /* find 1st unused volume */
		end;
		cseg.vcN = max (1, i - 1);		/* get index of last used volume (but at least 1) */
						/* and truncate volume chain */

		if cseg.vcN = 1 then		/* one (or no) volumes */
		     call ioa_ ("^a:  The only member of the volume set is ^a.", cseg.module, vl (1).volname);
		else do;
		     call ioa_ ("^a:  The members of the volume set are:", cseg.module);
		     string = "";			/* initialize volume set string */
		     k = 0;			/* zero entries per line count */
		     do j = 1 to cseg.vcN;		/* output name of each member volume */
			string = string || vl (j).volname || "  ";
			k = k + 1;
			if k = 8 then do;		/* line full? */
			     call ioa_ ("^a", string); /* write it */
			     string = "";
			     k = 0;
			end;
		     end;
		     if k ^= 0 then call ioa_ ("^a", string); /* write last line */
		end;
	     end;
	end;

force_detach: mask = "0"b;				/* initialize ips mask */
	on any_other call handler;			/* pick up interrupts */
	call hcs_$set_ips_mask ("0"b, mask);		/* mask all */
	iocbP -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null; /* iocb now detached */
	call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
	call hcs_$reset_ips_mask (mask, mask);
	if cP ^= null then do;			/* cseg still around */
	     if cseg.rlP ^= null then do;		/* read_length_ segment still around */
		call hcs_$terminate_noname (cseg.rlP, 0); /* disappear it */
		cseg.rlP = null;
	     end;
	     cseg.file_set_lock, cseg.file_lock = "0"b;	/* so unlock it */
	end;
	return;




handler:	procedure;				/* intercept any faults during iocb manipulation */
dcl 1 ti aligned,
    2 version fixed bin init (0),
    2 code fixed bin (35);

	     if mask ^= "0"b then do;			/* IPS interrupts masked */
		ti.code = error_table_$unable_to_do_io; /* very bad trouble */
		call terminate_process_ ("fatal_error", addr (ti)); /* kill the process */
	     end;
	     call continue_to_signal_ (0);
	     return;
	end handler;


     end tape_ansi_detach_;




		    tape_ansi_file_cntl_.pl1        12/17/86  0926.4r w 12/17/86  0829.4      913473



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




/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*                                                                    */
/*  tape_ansi_file_cntl_                                              */
/*                                                                    */
/*       Main logic module of tape_ansi_.  See individual entries     */
/*  for details of use and calling sequence.                          */
/*                                                                    */
/*  0) Created:   10/04/74 by Ross E. Klinger                         */
/*  1) Modified:  11/04/76 by Janice B. Phillipps                     */
/*  2) Modified:  04/11/79 by C. D. Tavares for authentication and    */
/*                         resource management                        */
/*  3) Modified:  9/79	by R.J.C. Kissel for new tseg		*/
/*  4) Modified:  4/82 by J. A. Bush for block sizes > 8192 bytes     */
/*		   and to remove tape_ibm_ HDR2 density check     */
/*                                                                    */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/* format: style3,ind3,dclind6,idind32 */
tape_ansi_file_cntl_:
   procedure;					/* This entry not used */

/* arguments */
dcl   iocbP		        ptr,		/* pointer to iocb */
      open_mode		        fixed bin,		/* opening mode */
      extend_bit		        bit (1) aligned,	/* extend at open time */
      code		        fixed bin (35);	/* error code */

%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;

%include tape_ansi_fl;

%include ansi_vol1;

%include ibm_vol1;

%include ansi_hdr1;

%include ansi_hdr2;

%include ibm_hdr1;

%include ibm_hdr2;

%include rcp_volume_formats;

%include rcp_resource_types;


/* automatic storage */
dcl   answer		        char (128) varying,
      cc			        fixed bin,		/* consistency code */
						/* 0 - invalidate volume position */
						/* 1 - invalidate volume position and current file link */
						/* 2 - invalidate position, current file link, write EOV TM */
      com_text		        char (64) varying,
      (eofs, close_eot, format_override, new_link)
			        bit (1),
      mask		        bit (36) aligned,
      testP		        ptr,
      search_id		        char (17),		/* search file chain/tape for this file id */
      t			        fixed bin,
      t1			        picture "9",
      t2			        picture "99",
      t4			        picture "9999",
      t5			        picture "99999",
      t6			        picture "999999",
      tstring		        char (32) varying,	/* open description temporary */
      vn			        char (32);		/* volume name */

dcl   1 qi		        aligned,		/* query info structure */
        2 version		        fixed bin init (2),
        2 yes_no		        bit (1) unaligned,
        2 suppress_name	        bit (1) unaligned,
        2 scode		        fixed bin (35),
        2 qcode		        fixed bin (35) init (0);

/* internal static */
dcl   ansi_format_chars	        char (4) internal static init ("UFDS"),
      ibm_format_chars	        char (4) internal static init ("UFVV"),
      ibm_block_codes	        char (4) internal static init (" BSR"),
      l1id		        (3) char (4) internal static init ("HDR1", "EOF1", "EOV1"),
      l2id		        (3) char (4) internal static init ("HDR2", "EOF2", "EOV2"),
      tag			        (4) char (12) varying internal static
			        init (" -extend", " -modify", " -generate", " -create");

dcl   dummy_label		        (2) char (76) internal static
			        init (
			        "0000000000000000000000000000000000000000000000000000000000000000000000000000",
						/* IBM dummy HDR1 label */
			        "!!DUMMY FILE ID!!******00010001000100 00000 00000 000000MULTICS ANSI        ");
						/* ANSI dummy HDR1/EOF1 label */

dcl   max_reclen		        (3) fixed bin internal static init (99999, 32756, 32763);
						/* ANSI - OS/VS - DOS/VM */

dcl   UL			        (2) char (3) internal static init ("UHL", "UTL");
						/* user label id's */

dcl   debug		        bit (1) internal static initial ("0"b);
						/* debug switch */

/* based storage */
dcl   label_type		        char (3) based (addr (cseg.lbl_buf));

dcl   sync_buf		        char (80) based (cseg.syncP);
						/* 80 character overlay on synchronous IO buffer */


/* conditions */
dcl   (any_other, area, cleanup, conversion)
			        condition;

/* builtin functions */
dcl   (addr, bit, char, fixed, index, length, ltrim, max, mod, null, prec, substr, verify)
			        builtin;

/* external procedures */
dcl   tape_ansi_lrec_io_$close        ext entry (ptr, fixed bin (35)),
      tape_ansi_lrec_io_$read_record  ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
      tape_ansi_lrec_io_$write_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)),
      ascii_to_ebcdic_	        ext entry (char (*), char (*)),
      command_query_	        ext entry options (variable),
      continue_to_signal_	        ext entry (fixed bin (35)),
      tape_ansi_control_	        ext entry (ptr, char (*), ptr, fixed bin (35)),
      tape_ansi_detach_	        ext entry (ptr, fixed bin (35)),
      ebcdic_to_ascii_	        ext entry (char (*), char (*)),
      tape_ansi_file_cntl_$close      ext entry (ptr, fixed bin (35)),
      tape_ansi_file_cntl_$open       ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
      hcs_$reset_ips_mask	        ext entry (bit (36) aligned, bit (36) aligned),
      hcs_$set_ips_mask	        ext entry (bit (36) aligned, bit (36) aligned),
      tape_ansi_ibm_lrec_io_$close    ext entry (ptr, fixed bin (35)),
      tape_ansi_ibm_lrec_io_$read_record
			        ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
      tape_ansi_ibm_lrec_io_$write_record
			        ext entry (ptr, ptr, fixed bin (21), fixed bin (35)),
      ioa_		        ext entry options (variable),
      iox_$propagate	        ext entry (ptr),
      tape_ansi_mount_cntl_$mount     ext entry (ptr, fixed bin, fixed bin (35)),
      tape_ansi_mount_cntl_$remount   ext entry (ptr, fixed bin, fixed bin, fixed bin (35)),
      tape_ansi_position_	        ext entry (ptr, fixed bin, fixed bin (21), fixed bin (35)),
      tape_ansi_read_length_	        ext entry (ptr, fixed bin (21), fixed bin (35)),
      tape_ansi_tape_io_$get_buffer   ext entry (ptr, ptr, fixed bin (35)),
      tape_ansi_tape_io_$open	        ext entry (ptr),
      tape_ansi_tape_io_$order        ext entry (ptr, char (3), fixed bin, fixed bin (35)),
      tape_ansi_tape_io_$sync_read    ext entry (ptr, fixed bin, fixed bin (35)),
      tape_ansi_tape_io_$sync_write   ext entry (ptr, fixed bin, fixed bin (35)),
      terminate_process_	        ext entry (char (*), ptr),
      canon_for_volume_label_	        ext entry (char (*), char (*), char (*), fixed bin, fixed bin (35)),
      authenticate_		        ext entry (char (*)) returns (char (3) aligned);


/* external static */
dcl   (
      error_table_$device_limit_exceeded,
      error_table_$discrepant_block_count,
      error_table_$duplicate_file_id,
      error_table_$eof_record,
      error_table_$end_of_info,
      error_table_$eov_on_write,
      error_table_$file_aborted,
      error_table_$file_busy,
      error_table_$incompatible_attach,
      error_table_$incompatible_encoding_mode,
      error_table_$incompatible_file_attribute,
      error_table_$insufficient_open,
      error_table_$invalid_block_length,
      error_table_$invalid_cseg,
      error_table_$invalid_expiration,
      error_table_$invalid_file_set_format,
      error_table_$invalid_label_format,
      error_table_$invalid_record_length,
      error_table_$invalid_volume_sequence,
      error_table_$noalloc,
      error_table_$no_file,
      error_table_$no_next_volume,
      error_table_$positioned_on_bot,
      error_table_$unable_to_do_io,
      error_table_$unexpired_file,
      error_table_$unexpired_volume,
      error_table_$uninitialized_volume
      )			        fixed bin (35) ext static;

dcl   sys_info$max_seg_size	        fixed bin (35) external static;

open:
   entry (iocbP, open_mode, extend_bit, code);

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to control segment */

      if cseg.invalid
      then
         do;					/* is control segment invalid? */
	  code = error_table_$invalid_cseg;
	  return;
         end;

      if cseg.file_lock
      then
         do;					/* is file in use (by previous invocation)? */
	  code = error_table_$file_busy;
	  return;
         end;
      else
         do;
	  cc = 0;					/* minimal consistency requirement */
	  on cleanup
	     begin;				/* insure file chain <--> tape consistency */
	        call consistent;
	        cseg.file_lock = "0"b;		/* unlock the file */
	     end;
	  cseg.file_lock = "1"b;			/* not in use - now it is */
         end;

      if extend_bit
      then
         do;					/* extend at open time not allowed */
bad_open:
	  code = error_table_$incompatible_attach;
	  go to valid_exit;
         end;

      if open_mode = 4
      then
         do;					/* sequential input */
	  tstring = "sequential_input";		/* set for open description */
	  search_id = fd.file_id;			/* set search identifier */
         end;

      else
         do;					/* sequential output */
	  if cseg.output_mode = 0
	  then go to bad_open;			/* no output mode specified */
	  if open_mode = 5
	  then tstring = "sequential_output";
	  else go to bad_open;
	  tstring = tstring || tag (output_mode);	/* append output mode keyword */
	  if cseg.replace_id ^= ""
	  then search_id = cseg.replace_id;		/* search for the replace name */
	  else search_id = fd.file_id;		/* otherwise, search for -name file_id */
         end;

      cseg.open_mode = open_mode;			/* save open mode in control segment */

      on area
         begin;					/* handle full control segment */
	  code = error_table_$noalloc;
	  go to er_exit;
         end;

      new_link = "0"b;				/* initialize for searching */
      cseg.flP = cseg.fcP;				/* start at beginning of chain */
      do testP = fl.nextP repeat fl.nextP;		/* loop through file chain */

         if testP ^= null
         then cseg.flP = testP;			/* link exists - use it */
         else
	  do;					/* link does not exist - build it */
	     new_link = "1"b;			/* this is a new link */
	     cc = 1;				/* don't leave defective links */
	     call build1 (code);			/* make the link */
	     if code ^= 0
	     then go to er_exit;
	  end;

         if fl.flX = -1
         then
	  do;					/* the link is an end-of-file-set link */
	     if append_file ()
	     then go to create_file;			/* appending file to eofs */
	     else
	        do;				/* not appending, therefore file not found */
		 code = error_table_$no_file;
		 go to valid_exit;
	        end;
	  end;

         if desired_file ()
         then
	  do;					/* found our file */
	     if cseg.open_mode = 4
	     then
	        do;				/* opened for sequential_input */
		 if ^new_link
		 then call desired_check;		/* check chain-tape consistency */
		 go to input;
	        end;
	     else
	        do;				/* opened for sequential_output */
		 if cseg.output_mode = 1
		 then go to extend_chain;		/* -extend - get to last section */
		 else
		    do;				/* -modify, -generate, or -create */
		       if ^new_link
		       then call desired_check;	/* check chain-tape consistency at 1st section */
		       if cseg.output_mode = 2
		       then go to extend_chain;	/* need version # from last section */
		       else
			do;			/* -generate or -create */
			   if fd.expiration > fl.backP -> fl.expiration
			   then
			      do;			/* check expiration */
			         code = error_table_$invalid_expiration;
			         go to valid_exit;
			      end;
			   go to output;
			end;
		    end;
	        end;
	  end;

         if new_link
         then
	  do;					/* new link - only partially built */
	     call build2 (code);
	     if code ^= 0
	     then go to er_exit;
	  end;

      end;

extend_chain:					/* extend file chain to last section */
      if debug
      then call debug_print ("extend_chain");
      if new_link
      then
         do;					/* complete link if just built */
	  call build2 (code);
	  if code ^= 0
	  then go to er_exit;
         end;

      testP = cseg.flP;				/* save pointer to first section's link */
      do while (fl.eox = 2);				/* get to last section */
         if fl.nextP = null
         then
	  do;					/* next link doesn't exist */
	     new_link = "1"b;			/* indicate new links in chain */
	     cc = 1;				/* don't leave defective links */
	     call build1 (code);			/* build it */
	     if code ^= 0
	     then go to er_exit;
	     if fl.flX = -1
	     then
	        do;				/* trouble - need more sections, but eofs */
		 code = error_table_$invalid_file_set_format;
		 go to valid_exit;			/* an error, but all is consistent */
	        end;
	     call build2 (code);
	     if code ^= 0
	     then go to er_exit;
	  end;
         else cseg.flP = fl.nextP;			/* link exists */
      end;

      if cseg.output_mode = 1
      then
         do;					/* extending chain for -extend */
	  if ^new_link
	  then call desired_check;			/* check chain-tape consistency */
	  go to output;
         end;
      else
         do;					/* extended chain for -modify */
	  cseg.flP = testP;				/* restore pointer to first section's link */
	  go to output;
         end;

input:						/* file is to be read */
      if debug
      then call debug_print ("input");
      cc = 0;					/* minimal consistency requirement */
      call setup_for_read;				/* complete file data from file link */
      call lrec_open;				/* perform final checks and initialization */

/* INSERT USER LABEL PROCESSING HERE */

      call move_tape_ (fl.vlX, fl.flX, 1, code);		/* move to 1st data block */
      if code ^= 0
      then go to er_exit;
      go to done;					/* set up iocb and exit */

output:
      if debug
      then call debug_print ("output");			/* extend, modify, generate, or create file */
      cc = 0;					/* minimal consistency requirement */

      if ^cseg.force
      then
         do;					/* check if file is expired */
	  if fl.expiration > fd.creation
	  then
	     do;					/* file is not expired */
	        if ^write_permit ()
	        then
		 do;				/* user said don't overwrite */
		    code = error_table_$unexpired_file;
		    go to valid_exit;
		 end;
	     end;
         end;

      call truncate_chains;				/* truncate file and volume chains */
      call build_eofsl;				/* append an eofs link */
      go to action_type (cseg.output_mode);		/* process the file */

extend_file:
modify_file:
action_type (1):
action_type (2):
      if debug
      then call debug_print ("extend/modify");

/* INSERT USER LABEL PROCESSING TO READ LABELS BEFORE WRITING DATA */

      if cseg.output_mode = 1
      then call move_to_EOD;				/* position to end of data to extend */
      else
         do;					/* modify */
	  call move_tape_ (fl.vlX, fl.flX, 1, code);	/* move to 1st data block */
	  if code ^= 0
	  then go to er_exit;
         end;
      cc = 1;					/* don't leave defective file links */
      call setup_for_extend_modify;			/* load file data from file link */
      call lrec_open;				/* perform final checks and initialization */
      if cseg.output_mode = 1
      then call extend_check;				/* should last block be re-written? */
      go to done;

generate_file:
action_type (3):
      if debug
      then call debug_print ("generate_file");
      cc = 1;					/* don't leave defective file links */
      call setup_for_generate;
      go to common;

create_file:
action_type (4):
      if debug
      then call debug_print ("create");
      cc = 1;					/* don't leave defective file links */
      call setup_for_create;				/* load file link from file data */

common:
      call lrec_open;				/* perform final checks and initialization */
      call move_tape_ (fl.vlX, fl.flX, 0, code);		/* position to write header labels */
      if code ^= 0
      then go to er_exit;
      cc = 2;					/* don't leave defective tape file */
      call write_HDRs (code);				/* write header labels */
      if code ^= 0
      then go to er_exit;				/* trouble */
      call write_TM (1, code);			/* write header TM */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then go to er_exit;			/* trouble - (ignore EOT) */
      call back_TM (1, code);				/* back into headers */
      if code ^= 0
      then go to er_exit;				/* trouble */
      go to done;					/* fill iocb and exit */

done:
      mask = "0"b;					/* ips interrupts not masked yet */
      cseg.open_description.length = length (tstring);	/* prepare open description */
      cseg.open_description.string = tstring;
      revert cleanup;
      on any_other call handler;			/* pick up any condition */
      call hcs_$set_ips_mask ("0"b, mask);		/* mask all ips interrupts */
      iocbP -> iocb.actual_iocb_ptr -> iocb.close = tape_ansi_file_cntl_$close;
      if cseg.open_mode = 5
      then
         do;					/* sequential output */
	  if cseg.standard = 1
	  then iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_lrec_io_$write_record;
	  else iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_ibm_lrec_io_$write_record;
         end;
      else
         do;					/* sequential input */
	  if cseg.standard = 1
	  then iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_lrec_io_$read_record;
	  else iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_ibm_lrec_io_$read_record;
	  iocbP -> iocb.actual_iocb_ptr -> iocb.read_length = tape_ansi_read_length_;
	  iocbP -> iocb.actual_iocb_ptr -> iocb.position = tape_ansi_position_;
         end;
      iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (cseg.open_description);
      call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
      call hcs_$reset_ips_mask (mask, mask);		/* permit ips interrupts */
      cseg.file_lock = "0"b;				/* open complete - unlock the file */
      return;

er_exit:
      call consistent;

valid_exit:
      cseg.file_lock = "0"b;				/* open complete - unlock the file */
      return;

abort_file:
   procedure;					/* cleanup after defective file */
      if debug
      then call debug_print ("abort_file");

      vl (fl.vlX).cflX = 0;				/* invalidate volume position */

      qi.yes_no = "1"b;				/* want yes or no answer */
      qi.suppress_name = "0"b;			/*  print module name */
      qi.scode = error_table_$file_aborted;
      qi.qcode = 0;
      call command_query_ (addr (qi), answer, cseg.module,	/* query user */
         "Error while writing labels of file ""^a"", section ^d.
The defective section invalidates the structure of the entire file set.
Do you want to delete the defective section?", fl.file_id, fl.section);

      if answer = "no"
      then
         do;					/* volume format will be invalid */
	  call write_TM (2, 0);			/* try to write 2 TM anyway */
	  go to abort_fail1;
         end;

      cseg.flP = fl.backP;				/* back up to previous section or file */
      call truncate_chains;				/* truncate file and volume chains */
      call build_eofsl;				/* add an end of file set link */

      if fl.flX = 0
      then
         do;					/* bad section was first of file set */
	  call initialize_volume (1, code);		/* initialize the volume */
	  if code ^= 0
	  then go to abort_fail;
         end;
      else
         do;					/* bad section wasn't first of file set */
	  if fl.eox = 1
	  then
	     do;					/* bad section was first section of file */
	        call move_tape_ (fl.vlX, fl.flX + 1, 0, code);
						/* position to write TM after EOF's */
	        if code ^= 0
	        then go to abort_fail;
	     end;
	  else
	     do;					/* bad section wasn't first section of file */
	        call move_tape_ (fl.vlX, fl.flX, 2, code);/* position to re-write trailers */
	        if code ^= 0
	        then go to abort_fail;
	        cseg.blkcnt = fl.blkcnt;		/* set block count to be recorded */
	        call write_EOFs (code);		/* change EOV to EOF */
	        if code ^= 0
	        then go to abort_fail;
	     end;
         end;

      call write_TM (2, code);			/* write the TMs */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then go to abort_fail;

      code = error_table_$file_aborted;
      return;

abort_fail:
      call ioa_ ("^a: Deletion failed: unable to restore valid file set format.", cseg.module);
abort_fail1:
      vl (fl.vlX).cflX = 0;				/* invalidate volume position */
      cseg.flP = cseg.fcP;				/* set pointer to eliminate file and volume chains */
      call truncate_chains;				/* wipe the slate clean */
      code = error_table_$invalid_file_set_format;
      return;

   end abort_file;

another_volume:
   procedure returns (bit (1));			/* queries user for next volume name */

dcl   msg			        char (80) varying;	/* message to user */
dcl   msg1		        char (length (msg)) based (addr (substr (msg, 1)));
						/* char (*) overlay for command_query_ */
dcl   L1			        fixed bin;

      qi.yes_no = "1"b;				/* want yes or no */
      qi.suppress_name = "0"b;			/* don't suppress module name */
      qi.scode = error_table_$no_next_volume;
      qi.qcode = 0;
      msg = "Reached end of volume.  Do you wish to terminate processing of this volume-set?";
      call command_query_ (addr (qi), answer, cseg.module, msg1);
      if answer = "yes"
      then return ("0"b);				/* finito */

      qi.yes_no = "0"b;				/* don't want yes or no */
      qi.suppress_name = "1"b;
ask:
      qi.scode = 0;					/* no scode when asking for name */
      msg = "Enter volume name of next volume (and optional comment).^/";
ask_raw:
      call command_query_ (addr (qi), answer, cseg.module, msg1);
      if answer = ""
      then go to ask;
      com_text = "";				/* initialize comment message */
      L1 = index (answer, " ") - 1;			/* scan for a blank */
      if L1 < 0
      then L1 = length (answer);

      call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, L1), vn, 0, code);
      if code ^= 0
      then
         do;
	  qi.scode = code;
	  msg = substr (answer, 1, L1) || "^/Enter volume name of next volume (and optional comment).^/";
	  go to ask_raw;
         end;

      answer = ltrim (substr (answer, L1 + 1));

      if substr (answer, 1, 8) = "-comment"
      then
         do;
	  answer = ltrim (substr (answer, 10));
	  go to comment;
         end;
      if substr (answer, 1, 4) = "-com"
      then
         do;
	  answer = ltrim (substr (answer, 6));
comment:
	  if length (answer) = 0
	  then ;					/* no comment */
	  else com_text = answer;
         end;
      else if answer = ""
      then ;
      else
         do;					/* invalid comment */
	  call ioa_ ("Comment is invalid.");
	  go to ask;
         end;
      return ("1"b);				/* volume name is ok - exit */

write_permit:
   entry returns (bit (1));				/* queries user for write permission */

      qi.yes_no = "1"b;				/* user must answer yes or no */
      qi.suppress_name = "0"b;
      qi.scode = error_table_$unexpired_file;
      qi.qcode = 0;
      call command_query_ (addr (qi), answer, cseg.module,	/* ask the user */
         "Do you want to overwrite the unexpired file ""^a""?", fl.file_id);
      if answer = "yes"
      then return ("1"b);
      else return ("0"b);

   end another_volume;

append_file:
   procedure returns (bit (1));			/* determines if a file is an append file */
      if debug
      then call debug_print ("append_file");

/*  If the file is an append file, set its sequence number in file     */
/*  data, and build an eofs link.                                      */
/*                                                                     */
/*  A file is an append file if:                                       */
/*                                                                     */
/*  1) cseg.open_mode = 5 and cseg.output_mode = 4                     */
/*             AND                                                     */
/*  2) fd.sequence =  0 (-number not specified)  or                    */
/*                    last sequence number of file set + 1.            */
/*		AND					*/
/*  3) -replace not specified					*/

      if cseg.open_mode = 4
      then return ("0"b);				/* open mode is input */
      if cseg.output_mode ^= 4
      then return ("0"b);				/* output mode is not create */
      if cseg.replace_id ^= ""
      then return ("0"b);				/* -replace specified therefore cannot append */

      if fd.sequence = 0
      then
         do;					/* -number not specified */
	  if cseg.flP = fd.nextP
	  then fd.sequence = 1;			/* file is 1st of new file set */
	  else fd.sequence = fl.backP -> fl.sequence + 1; /* file is 2, 3, ..... */
         end;

      else
         do;					/* -number specified */
	  if cseg.flP = fd.nextP
	  then
	     do;					/* file must be 1st of new file set */
	        if fd.sequence = 1
	        then go to yes;			/* and it is */
	        else return ("0"b);			/* isn't - error */
	     end;

	  else
	     do;					/* file need not be first, but last + 1 */
	        if fd.sequence = fl.backP -> fl.sequence + 1
	        then go to yes;			/* and it is */
	        else return ("0"b);			/* isn't - error */
	     end;
         end;

yes:
      if debug
      then call debug_print ("yes");
      if fd.expiration > fl.backP -> fl.expiration
      then
         do;					/* requested expiration > file set expiration */
	  code = error_table_$invalid_expiration;
	  go to valid_exit;
         end;
      cc = 1;					/* insure chain consistency */
      call make_eofsl_real;				/* make the eofs link a real link */
      call build_eofsl;				/* add a new eofs link */
      return ("1"b);				/* done! */

   end append_file;

back_TM:
   procedure (n, ecode);				/* backs over 1 or 2 TM adjusting volume link */
      if debug
      then call ioa_ ("back_TM ^d", n);
dcl   n			        fixed bin,
      cnt			        fixed bin,
      ecode		        fixed bin (35);

      do cnt = 1 to n;				/* 1 or 2 */
         call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
						/* backup over a TM */
         if ecode ^= 0
         then return;

         vl (fl.vlX).pos = vl (fl.vlX).pos - 1;
         if vl (fl.vlX).pos < 0
         then
	  do;					/* adjust for mod3 */
	     vl (fl.vlX).pos = vl (fl.vlX).pos + 3;
	     vl (fl.vlX).cflX = vl (fl.vlX).cflX - 1;
	  end;
      end;

      return;

   end back_TM;

build1:
   procedure (ecode);				/* build a file link and initialize */
dcl   ecode		        fixed bin (35);
      if debug
      then call debug_print ("build1");

      call build_fl;				/* build a file link */
      call move_tape_ (fl.vlX, fl.flX, 0, ecode);		/* position to read HDR1 */
      if ecode ^= 0
      then return;
      call read_HDR1 (eofs, ecode);			/* read the header 1 label */
      if ecode ^= 0
      then return;
      if eofs
      then
         do;					/* reached end of file set */
	  fl.flX = -1;				/* make the link an eofs link */
	  vl (fl.vlX).lflX = vl (fl.vlX).lflX - 1;	/* remove eofs link from volume link */
	  return;
         end;
      call fill_fl_from_HDR1 (ecode);			/* validate and store HDR1 data */
      if ecode ^= 0
      then return;
      call read_HDR2 (ecode);				/* try to read HDR2 label */
      if ecode ^= 0
      then return;
      if fl.HDR2
      then
         do;					/* if HDR2, validate and store its data */
	  call fill_fl_from_HDR2 (ecode);
	  if ecode ^= 0
	  then return;
         end;
      return;

   end build1;


build2:
   procedure (ecode);				/* 2nd part of link building */
dcl   ecode		        fixed bin (35);

      if debug
      then call debug_print ("build2");
      call move_tape_ (fl.vlX, fl.flX, 2, ecode);		/* position to trailer labels */
      if ecode ^= 0
      then return;
      call process_EOX (ecode);			/* process the trailer labels */
      return;

   end build2;


build_eofsl:
   procedure;					/* builds an end-of-file-set link */
      if debug
      then call debug_print ("eofsl");

      allocate fl in (chain_area) set (fl.nextP);		/*  build an eofs link */
      fl.nextP -> fl.backP = cseg.flP;
      fl.nextP -> fl.flX = -1;
      return;

   end build_eofsl;

build_fl:
   procedure;					/* build a file link on end of file chain */
      if debug
      then call debug_print ("build_fl");

      allocate fl in (chain_area) set (fl.nextP);		/*  allocate the link */
      fl.nextP -> fl.backP = cseg.flP;			/* set new link's back ptr to current link */
      cseg.flP = fl.nextP;				/* make the new link current */
      go to build_fl1;

make_eofsl_real:
   entry;						/* makes an eofs link a real link */
      if debug
      then call debug_print ("make_eofsl_real");

build_fl1:
      fl.flX = fl.backP -> fl.flX + 1;			/* set the link index */

      if fl.backP -> fl.eox = 2
      then
         do;					/* this link will be 1st on new volume */
	  fl.vlX = fl.backP -> fl.vlX + 1;		/* up volume link index for this file link */
	  vl (fl.vlX).fflX = fl.flX;			/* first file link on new volume is this file link */
	  vl (fl.vlX).lflX = fl.flX;			/* last file link on new volume is this file link */
         end;
      else
         do;					/* this link is not on a new volume */
	  fl.vlX = fl.backP -> fl.vlX;		/* use same volume index as previous link */
	  vl (fl.vlX).lflX = vl (fl.vlX).lflX + 1;	/* one more file link on volume */
         end;

      return;

   end build_fl;

consistent:
   procedure;					/* insures file chain/tape consistency */
      if debug
      then call debug_print ("consistent");

      go to recovery (cc);				/* perform appropriate consistency processing */

recovery (0):
      if cseg.flP ^= null
      then vl (fl.vlX).cflX = 0;			/* invalidate volume position */
      return;

recovery (1):
      if cseg.flP = null
      then return;					/* nothing can be done - exit */
      vl (fl.vlX).cflX = 0;				/* invalidate volume position */
      cseg.flP = fl.backP;				/* set pointer to previous link */
      call truncate_chains;				/* truncate file and volume chains */
      return;

recovery (2):
      if cseg.flP = null
      then return;					/* nothing can be done - exit */
      call abort_file;				/* truncate file and volume chains, write TM */
      return;

   end consistent;

creating_first:
   procedure returns (bit (1));			/* determines if creating 1st file of new file set */

      if debug
      then call debug_print ("creating_first?");
      if cseg.open_mode = 4
      then return ("0"b);
      if cseg.output_mode ^= 4
      then return ("0"b);
      if fd.sequence ^= 1
      then return ("0"b);
      if cseg.replace_id ^= ""
      then return ("0"b);

      return ("1"b);

   end creating_first;

desired_check:
   procedure;					/* insures that tape and file chain are consistent */
dcl   can_retry		        bit (1) initial ("1"b);
						/* permits 1 retry after re-positioning */

      if debug
      then call debug_print ("desired_check");

last_chance:
      call move_tape_ (fl.vlX, fl.flX, 0, code);		/* position to HDR labels */
      if code ^= 0
      then go to er_exit;

      call read_HDR1 (eofs, code);			/* read HDR1 label */
      if code ^= 0
      then go to er_exit;

      if eofs
      then
         do;					/* end of file set - shouldn't happen */
chain_tape_error:
	  if debug
	  then call debug_print ("chain_tape_error");
	  if can_retry
	  then
	     do;					/* re-position and try again */
	        can_retry = "0"b;			/* can only re-try once */
	        vl (fl.vlX).cflX = 0;			/* force rewind and re-position */
	        go to last_chance;			/* try again */
	     end;
	  code = error_table_$invalid_cseg;		/* re-try failed - disaster */
	  cseg.invalid = "1"b;			/* note for eventual deletion of cseg */
	  go to er_exit;
         end;

      if cseg.standard = 1
      then
         do;					/* ANSI */
	  if ansi_hdr1.file_id ^= fl.file_id
	  then go to chain_tape_error;		/* file id's must be identical */
	  on conversion go to chain_tape_error;
	  if fixed (ansi_hdr1.section) ^= fl.section
	  then go to chain_tape_error;		/* and section */
	  revert conversion;
         end;
      else if ibm_hdr1.dataset_id ^= fl.file_id
      then go to chain_tape_error;			/* IBM */

      return;

   end desired_check;

desired_file:
   procedure returns (bit (1));			/* determines if file wanted is current link */
      if debug
      then call debug_print ("desired_file?");

      if fl.section ^= 1
      then
         do;					/* don't investigate non-initial sections */
	  if debug
	  then call debug_print ("sec ne 1");
	  return ("0"b);
         end;

      if fd.sequence ^= 0
      then
         do;					/* -number specified */
	  if search_id = ""
	  then
	     do;					/* -name (or -replace) not specified */
	        if fd.sequence = fl.sequence
	        then go to match;			/* sequences match */
	        else go to no;			/* sequences don't match */
	     end;
	  else
	     do;					/* -name/replace specified */
	        if fd.sequence = fl.sequence
	        then
		 do;				/* -number matches */
		    if cseg.replace_id ^= ""
		    then
		       do;			/* -replace specified? */
			if cseg.replace_id = fl.file_id
			then go to match;		/* found it */
			code = error_table_$no_file;	/* file doesn't exist */
			go to valid_exit;
		       end;
		    if fd.file_id = fl.file_id
		    then go to match;		/* -name specified */
		    if cseg.open_mode = 5 & cseg.output_mode = 4
		    then go to match;		/* creation */
		    code = error_table_$no_file;	/* file doesn't exist */
		    go to valid_exit;
		 end;
	        else go to no;			/* -number doesn't match */
	     end;
         end;
      else
         do;					/* -number not specified */
	  if search_id = fl.file_id
	  then
	     do;					/* names match */
	        fd.sequence = fl.sequence;		/* set sequence in case not specified */
match:
	        if debug
	        then call debug_print ("yes");
	        return ("1"b);
	     end;
no:
	  if debug
	  then call debug_print ("no");
	  if cseg.output_mode = 4
	  then
	     do;					/* if -create specified */
	        if cseg.open_mode = 5
	        then
		 do;				/* and actually opened for output */
		    if fd.file_id = fl.file_id
		    then
		       do;			/* then names cannot be the same */
			code = error_table_$duplicate_file_id;
						/* if not desired file */
			go to valid_exit;
		       end;
		 end;
	     end;
	  return ("0"b);
         end;



   end desired_file;

extend_check:
   procedure;					/* checks if necessary to re-write last block */
dcl   buf			        char (8192) based aligned;
						/* IO buffer overlay */
dcl   (i, j)		        fixed bin;		/* temporaries */

      if debug
      then call debug_print ("extend_check");

      if cseg.blkcnt = 0
      then return;					/* no last blockto re-write */
      if fd.format ^= 2
      then return;					/* only FB format might need re-writing */
      if ^fd.blocked
      then return;

      call tape_ansi_tape_io_$order (cP, "bsr", 0, code);	/* position to read last block */
      if code ^= 0
      then go to er_exit;
      call tape_ansi_tape_io_$sync_read (cP, cseg.offset, code);
      if code ^= 0
      then go to er_exit;

      if cseg.standard = 2
      then
         do;					/* IBM labeled tape */
	  if mod (cseg.offset, fd.reclen) ^= 0
	  then return;				/* ^integral # of records */
	  if cseg.offset >= fd.blklen
	  then return;				/* block is full */
	  else go to rewrite;			/* more records can fit in block */
         end;

      if cseg.offset > fd.blklen
      then cseg.offset = fd.blklen;			/* ANSI - eliminate obvious padding */
      i = mod ((cseg.offset - fd.bo), fd.reclen);		/* # of chars not in complete record */
      if i ^= 0
      then
         do;					/* if any, see if all padding */
	  if verify (substr (cseg.syncP -> buf, cseg.offset - i + 1, i), "^") ^= 0
	  then return;				/* not all padding, irregularity */
	  else cseg.offset = cseg.offset - i;		/* all padding, must continue checking */
         end;

      i = (cseg.offset - fd.bo) / fd.reclen;		/* get # of complete records */
      do j = i to 1 by -1;				/* test each record for all "^" */
         if verify (substr (cseg.syncP -> buf, fd.bo + ((j - 1) * fd.reclen) + 1, fd.reclen), "^") = 0
         then cseg.offset = cseg.offset - fd.reclen;	/* drop padding */
         else go to rewrite_test;			/* not padding - test if block full */
      end;

rewrite_test:
      if cseg.offset >= fd.blklen
      then return;					/* block is full */
rewrite:
      call tape_ansi_tape_io_$order (cP, "bsr", 0, code);	/* position to rewrite */
      if code ^= 0
      then go to er_exit;
      call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, code);
						/* getting an IO buffer causes */
      if code ^= 0
      then go to er_exit;				/* iox_$close to call xxx_lrec_io_$close */
      cseg.blkcnt = cseg.blkcnt - 1;			/* so block count must now reflect tape position */
      substr (cseg.lrec.bufP -> buf, 1, cseg.offset) = substr (cseg.syncP -> buf, 1, cseg.offset);
      return;

   end extend_check;

fill_XXX1:
   procedure (x);					/* formats labels for output */
dcl   x			        fixed bin;		/* 1 - HDR | 2 - EOF | 3 - EOV */

      if debug
      then call debug_print ("fill_XXX1");

      ansi_hdr1P, ibm_hdr1P = addr (lbl_buf);		/* ANSI:IBM common - set pointer to label IO buffer */
      ansi_hdr1.label_id = l1id (x);			/* set label identifier */
      ansi_hdr1.file_id = fl.file_id;			/* IBM - dataset_id */
      ansi_hdr1.set_id = fl.canonical_set_id;		/* IBM - dataset_serial */

      if cseg.standard = 1
      then
         do;					/* ANSI */
	  t4 = fl.section;
	  ansi_hdr1.section = t4;
         end;
      else
         do;
	  t4 = fl.vlX;
	  ibm_hdr1.volume_sequence = t4;
         end;
      if fl.generation = 0 & cseg.standard ^= 1
      then
         do;					/* consider ANSI 0000 (=10000) case */
	  ibm_hdr1.generation = "";
	  ibm_hdr1.version = "";
         end;
      else
         do;
	  t4 = fl.generation;
	  ansi_hdr1.generation = t4;
	  t2 = fl.version;
	  ansi_hdr1.version = t2;
         end;
      t4 = fl.sequence;
      ansi_hdr1.sequence = t4;
      ansi_hdr1.creation = " " || fl.creation;
      ansi_hdr1.expiration = " " || fl.expiration;
      ansi_hdr1.access = fl.access;
      if x = 1
      then ansi_hdr1.blkcnt = "000000";
      else
         do;
	  t6 = cseg.lrec.blkcnt;
	  ansi_hdr1.blkcnt = t6;
         end;
      ansi_hdr1.system = fl.system;
      ansi_hdr1.reserved = "";
      return;

   end fill_XXX1;

fill_XXX2:
   procedure (x);					/* formats 2nd header/trailer label for writing */
dcl   x			        fixed bin;

      if debug
      then call debug_print ("fill_XXX2");
      if cseg.standard ^= 1
      then go to IBM_fill_XXX2;

      ansi_hdr2P = addr (lbl_buf);			/* set pointer to label IO buffer */
      ansi_hdr2.label_id = l2id (x);
      ansi_hdr2.format = substr (ansi_format_chars, fl.format, 1);
      t5 = fl.blklen;
      ansi_hdr2.blklen = t5;
      t5 = fl.reclen;
      ansi_hdr2.reclen = t5;
      if fl.system = fd.system
      then
         do;					/* fill these fields only on parochial file */
	  if x = 1
	  then ansi_hdr2.next_volname = "";
	  else ansi_hdr2.next_volname = fl.next_volname;
	  ansi_hdr2.blocked = char (fl.blocked);
	  t1 = fl.mode;
	  ansi_hdr2.mode = t1;
         end;
      else
         do;
	  ansi_hdr2.next_volname = "";
	  ansi_hdr2.blocked = "";
	  ansi_hdr2.mode = "";
         end;
      ansi_hdr2.system_reserved = "";
      t2 = fl.bo;
      ansi_hdr2.buffer_offset = t2;
      ansi_hdr2.reserved = "";
      return;

IBM_fill_XXX2:
      ibm_hdr2P = addr (cseg.lbl_buf);
      ibm_hdr2.label_id = l2id (x);
      ibm_hdr2.format = substr (ibm_format_chars, fl.format, 1);
      t5 = fl.blklen;
      ibm_hdr2.blksize = t5;
      t5 = fl.reclen;
      ibm_hdr2.lrecl = t5;
      t1 = cseg.density;
      ibm_hdr2.density = t1;
      if fl.section > 1
      then ibm_hdr2.dataset_position = "1";
      else ibm_hdr2.dataset_position = "0";
      ibm_hdr2.jobstep_id = "MULTICS /" || fd.creation;
      ibm_hdr2.recording_technique = "";
      ibm_hdr2.control_characters = fl.cc;
      ibm_hdr2.reserved1 = "";
      if ^fl.blocked
      then t = 1;					/* records not blocked */
      else t = 2;					/* records blocked */
      if fl.format = 4
      then t = t + 2;				/* spanned records */
      ibm_hdr2.block_attribute = substr (ibm_block_codes, t, 1);
						/* pick out block code */
      ibm_hdr2.reserved2 = "";
      return;

   end fill_XXX2;

fill_fl_from_HDR1:
   procedure (ecode);				/* fills file link from HDR1 data */
dcl   ecode		        fixed bin (35);
dcl   nv			        fixed bin;

      if debug
      then call debug_print ("fill_fl_from_HDR1");
      on conversion go to bad_hdr1;
      go to re_fill (cseg.standard);			/* processing for ANSI or IBM */

re_fill (1):
      fl.file_id = ansi_hdr1.file_id;
      fl.set_id = cseg.vl (fl.vlX).volname;
      fl.canonical_set_id = ansi_hdr1.set_id;
      fl.section = fixed (ansi_hdr1.section, 17);
      if fl.section = 0
      then go to bad_hdr1;
      fl.sequence = fixed (ansi_hdr1.sequence, 17);
      if fl.sequence = 0
      then go to bad_hdr1;

      if fl.section = 1
      then
         do;					/* check volume sequence validity */
	  if fl.sequence = 1
	  then
	     do;					/* file 1, section 1 */
	        if fl.flX ^= 1
	        then
		 do;				/* must be first link in file chain */
bad_seq:
		    ecode = error_table_$invalid_volume_sequence;
		    return;
		 end;
	     end;
	  else
	     do;					/* file n > 1, section 1 */
	        if fl.flX = 1
	        then
		 do;				/* cannot be first link in file chain */
new_file_set:
		    if ^creating_first ()
		    then go to bad_seq;		/* unless creating 1st file */
		    if substr (ansi_hdr1.expiration, 2, 5) <= fd.creation
		    then go to re_init;
		    if initialize_permitA (fl.vlX)
		    then
		       do;			/* not expired - query user for permission */
re_init:
			call initialize_volume (fl.vlX, ecode);
						/* said ok (or expired) - do it */
			if ecode ^= 0
			then return;
			call move_tape_ (fl.vlX, fl.flX, 0, ecode);
						/* re-position to HDR1 */
			if ecode ^= 0
			then return;
			call read_HDR1 (eofs, ecode); /* read HDR1 - eof can't happen */
			if ecode ^= 0
			then return;
			go to re_fill (cseg.standard);/* processing for ANSI or IBM */
		       end;
		    ecode = error_table_$unexpired_volume;
						/* user said no */
		    return;
		 end;
	        else if fl.backP -> fl.eox = 2
	        then go to bad_seq;			/* previous file section must be last */
	     end;
         end;
      else
         do;					/* file n >_ 1, section n > 1 */
	  if fl.flX = 1
	  then go to new_file_set;			/* cannot be first link in file chain */
	  if fl.section ^= fl.backP -> fl.section + 1
	  then go to bad_seq;			/* section must be 1 more than previous */
         end;

finish_up:
      fl.generation = fixed (ansi_hdr1.generation, 17);
      fl.version = fixed (ansi_hdr1.version, 17);
      fl.creation = substr (ansi_hdr1.creation, 2, 5);
      fl.expiration = substr (ansi_hdr1.expiration, 2, 5);
      fl.access = ansi_hdr1.access;
      fl.blkcnt = fixed (ansi_hdr1.blkcnt, 35);
      fl.system = ansi_hdr1.system;
      return;


re_fill (2):
re_fill (3):
      fl.file_id = ibm_hdr1.dataset_id;
      fl.set_id = cseg.vl (fl.vlX).volname;
      fl.canonical_set_id = ibm_hdr1.dataset_serial;
      nv = fixed (ibm_hdr1.volume_sequence, 17);
      if nv = 0
      then
         do;					/* volume sequence is 0 */
	  if substr (lbl_buf, 5, 76) = dummy_label (1)
	  then
	     do;					/* HDR1 is a dummy */
	        if fl.flX = 1
	        then if ^creating_first ()
		   then
		      do;				/* if so, only creating 1st file */
		         ecode = error_table_$no_file;	/* ...of new file set has meaning */
		         return;
		      end;
	        fl.section = 1;			/* force meaningful values */
	        fl.sequence = 1;
	        go to finish_up;
	     end;
	  else go to bad_hdr1;			/* not dummy HDR1, an error */
         end;
      if fl.flX = 1
      then fl.section = 1;				/* dummy up section number */
      else
         do;					/* tests can be made */
	  if fl.backP -> fl.file_id = fl.file_id
	  then fl.section = fl.backP -> fl.section + 1;
	  else fl.section = 1;
         end;
      fl.sequence = fixed (ibm_hdr1.dataset_sequence, 17);
      if fl.sequence = 0
      then go to bad_hdr1;

      if nv = 1
      then
         do;					/* label says 1st volume */
	  if fl.vlX = 1
	  then ;					/* and so it is */
	  else go to bad_seq;			/* definite error */
         end;
      else if fl.vlX ^= nv
      then go to new_file_set;			/* volume isn't _nth - see why */
      if fl.sequence = 1
      then
         do;					/* check file and volume sequences */
	  if nv = 1
	  then
	     do;					/* file 1 on volume 1 */
	        if fl.flX ^= 1
	        then go to bad_seq;			/* must be 1st file link */
	        else ;				/* it is, fine */
	     end;
	  else
	     do;					/* file 1 on volume nv > 1 */
	        if nv = fl.backP -> fl.vlX + 1
	        then ;				/* fine, volumes in sequence */
	        else go to bad_seq;
	     end;
         end;
      else if fl.flX = 1
      then go to new_file_set;			/* perhaps error - find out */
      go to finish_up;


bad_hdr1:
      ecode = error_table_$invalid_label_format;
      return;


   end fill_fl_from_HDR1;

fill_fl_from_HDR2:
   procedure (ecode);				/* fills file link from HDR2 data */
dcl   ecode		        fixed bin (35);

dcl   canon_std		        (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);

      if debug
      then call debug_print ("fill_fl_from_HDR2");
      on conversion go to bad_hdr2;
      if cseg.standard ^= 1
      then go to IBM_fill_fl_from_HDR2;

      fl.format = index (ansi_format_chars, ansi_hdr2.format);
      if fl.format = 0
      then go to bad_hdr2;
      fl.blklen = fixed (ansi_hdr2.blklen, 17);
      if fl.blklen = 0
      then go to bad_hdr2;
      if fl.blklen > cseg.buf_size
      then
         do;					/* we don't have enough room to read it */
	  fl.blklen = fl.blklen + mod (fl.blklen, 4);	/* make it mod 4 */
	  call
	     ioa_ ("^a^/Reattach with a ""-block ^d"" specification.",
	     "Block size in HDR2 label > block size allowed for this attachment.", fl.blklen);
	  go to bad_hdr2;
         end;
      if fl.format ^= 1
      then fl.reclen = fixed (ansi_hdr2.reclen, 17);	/* reclen only for F, D, and S */
      if fl.system ^= ""
      then
         do;					/* fields may be valid */
	  fl.bo = fixed (ansi_hdr2.buffer_offset, 17);
	  if fl.system = fd.system
	  then
	     do;					/* following is system specific */
	        if old_ansi_hdr2_system_use.system_reserved = ""
	        then
		 do;				/* old-format hdr2 label */
		    fl.blocked = bit (old_ansi_hdr2_system_use.blocked);
		    fl.mode = fixed (old_ansi_hdr2_system_use.mode, 17);
		    fl.canonical_next_volname = old_ansi_hdr2_system_use.canonical_next_volname;
		    fl.next_volname = "";
		 end;
	        else
		 do;
		    fl.blocked = bit (ansi_hdr2.system_use.blocked);
		    fl.mode = fixed (ansi_hdr2.system_use.mode, 17);
		    fl.next_volname = ansi_hdr2.system_use.next_volname;
		    if fl.next_volname ^= ""
		    then
		       do;
			call
			   canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), fl.next_volname,
			   fl.canonical_next_volname, canon_std (cseg.standard), ecode);
			if ecode ^= 0
			then goto bad_hdr2;
		       end;
		    else fl.canonical_next_volname = "";
		 end;
	     end;
         end;
      return;

IBM_fill_fl_from_HDR2:
      fl.format = index (ibm_format_chars, ibm_hdr2.format);
      if fl.format = 0
      then go to bad_hdr2;
      fl.blklen = fixed (ibm_hdr2.blksize, 17);
      if fl.blklen = 0
      then go to bad_hdr2;
      if fl.format ^= 1
      then fl.reclen = fixed (ibm_hdr2.lrecl, 17);	/* reclen only for F and V */

/*      t = fixed (ibm_hdr2.density, 17); This is stupid. Since we are already */
/*      if cseg.density ^= t    reading the tape at the right density, who cares */
/*      then go to bad_hdr2;    what the HDR2 label says the density is. */
      if ibm_hdr2.dataset_position = "1"
      then
         do;					/* should not be 1st volume */
	  if fl.vlX = 1
	  then go to bad_hdr2;			/* cant be 1st vol */
	  if fl.backP -> fl.eox ^= 2
	  then go to bad_hdr2;			/* previous must have EOV labels */
         end;
      if ibm_hdr2.recording_technique ^= ""
      then go to bad_hdr2;
      t = index (ibm_block_codes, ibm_hdr2.block_attribute);
      if t = 0
      then go to bad_hdr2;
      if t > 2
      then
         do;					/* indicated spanned blocks */
	  t = t - 2;
	  if fl.format = 3
	  then /* set it to V spanned only if hdr2.format is "V" */
	       fl.format = 4;
         end;
      if t = 1
      then fl.blocked = "0"b;
      else fl.blocked = "1"b;
      fl.cc = ibm_hdr2.control_characters;
      return;

bad_hdr2:
      ecode = error_table_$invalid_label_format;
      return;

   end fill_fl_from_HDR2;

fill_fdhdr2_from_fl:
   procedure;					/* fills fd hdr2 data from fl if section has HDR2 */
      if debug
      then call debug_print ("fill_fdhdr2_from_fl");

      if fl.HDR2
      then
         do;					/* fill only if HDR2 exists */
	  if fd.format ^= 0
	  then
	     do;					/* -format in attach description */
	        if fd.format ^= fl.format
	        then
		 do;				/* incompatible file attribute specification */
mis_match:
		    code = error_table_$incompatible_file_attribute;
		    go to er_exit;
		 end;
	        else format_override = "1"b;		/* -format's blocking attribute to be used */
	     end;
	  else
	     do;					/* -format not specified */
	        fd.format = fl.format;		/* use value from HDR2 */
	        format_override = "0"b;		/* blocking attribute not specified */
	     end;

	  if fd.blklen ^= 0
	  then
	     do;
	        if fd.blklen ^= fl.blklen
	        then go to mis_match;
	        else ;
	     end;
	  else fd.blklen = fl.blklen;

	  if fd.format ^= 1
	  then
	     do;					/* record length undefined for U format */
	        if fd.reclen ^= 0
	        then
		 do;				/* only test if specified */
		    if fd.reclen <= max_reclen (cseg.standard)
		    then
		       do;			/* fits in HDR2 reclen field */
			if fd.reclen ^= fl.reclen
			then go to mis_match;	/* must match */
			else ;			/* ok */
		       end;
		    else if fl.reclen ^= 0
		    then go to mis_match;		/* doesn't fit - 0 */
		 end;
	        fd.reclen = fl.reclen;
	     end;

	  if cseg.standard = 1
	  then
	     do;					/* ANSI */
	        if fl.system ^= ""
	        then
		 do;				/* certain HDR2 fields are valid */
		    fd.bo = fl.bo;			/* CANNOT BE USER-SPECIFIED */
		    if fl.system = fd.system
		    then
		       do;			/* system-defined data is valid */
			if format_override
			then
			   do;			/* blocking attributes must match */
			      if fd.blocked ^= fl.blocked
			      then go to mis_match;
			      else ;
			   end;
			else fd.blocked = fl.blocked;
			if fd.mode ^= 0
			then
			   do;
			      if fd.mode ^= fl.mode
			      then go to mis_match;
			      else ;
			   end;
			else fd.mode = fl.mode;
		       end;
		 end;
	        else fd.bo = 0;			/* must be 0 if fl.system = "" */
	     end;
	  else
	     do;					/* IBM */
	        if format_override
	        then
		 do;
		    if fd.blocked ^= fl.blocked
		    then go to mis_match;
		    else ;
		 end;
	        else fd.blocked = fl.blocked;
	        fd.cc = fl.cc;			/* CANNOT BE USER-SPECIFIED */
	     end;
         end;
      return;

   end fill_fdhdr2_from_fl;

fill_flhdr2_from_fd:
   procedure;					/* fill fl hdr2 data from fd and defaults */
      if debug
      then call debug_print ("fill_flhdr2_from_fd");

      if fd.format = 0
      then
         do;					/* apply defaults */
	  if cseg.output_mode ^= 4
	  then
	     do;					/* defaults permitted only for create */
no_defaults:
	        code = error_table_$insufficient_open;
	        go to er_exit;
	     end;
	  fd.format = 3;				/* D or V format */
	  fd.blocked = "1"b;			/* blocked */
         end;
      fl.format = fd.format;
      fl.blocked = fd.blocked;

      if fd.blklen = 0
      then
         do;					/* apply defaults */
	  if cseg.output_mode ^= 4
	  then go to no_defaults;
	  if cseg.standard = 1
	  then fd.blklen = 2048;			/* ANSI */
	  else fd.blklen = 8192;			/* IBM */
         end;
      fl.blklen = fd.blklen;

      if fd.reclen = 0
      then
         do;					/* apply defaults */

	  if cseg.output_mode ^= 4
	  then go to no_defaults;
	  go to default_reclen (fd.format);		/* perform appropriate reclen default action */

default_reclen (2):
	  fd.reclen = fd.blklen;			/* F format */
	  go to set_fl_reclen;

default_reclen (3):
	  if cseg.standard = 1
	  then fd.reclen = fd.blklen;			/* D format */
	  else fd.reclen = fd.blklen - 4;		/* V format */
	  go to set_fl_reclen;

default_reclen (4):
	  fd.reclen = prec (sys_info$max_seg_size * 4, 21);
						/* S or VS format */

         end;

default_reclen (1):					/* U format - 0 is correct */
set_fl_reclen:
      if fd.reclen > max_reclen (cseg.standard)
      then fl.reclen = 0;
      else fl.reclen = fd.reclen;

      if fd.mode = 0
      then
         do;					/* apply defaults */
	  if cseg.standard = 1
	  then fd.mode = 1;				/* ANSI - ASCII */
	  else fd.mode = 2;				/* IBM - EBCDIC */
         end;
      fl.mode = fd.mode;

      fl.cc = fd.cc;
      fl.bo = 0;
      fl.next_volname, fl.canonical_next_volname = "";
      return;

   end fill_flhdr2_from_fd;

fill_new_section_fl:
   procedure;					/* initializes new file section link */
      if debug
      then call debug_print ("fill_new_section_fl");

      fl.file_id = fl.backP -> fl.file_id;		/* copy from previous link */
      fl.set_id = fl.backP -> fl.set_id;
      fl.canonical_set_id = fl.backP -> fl.canonical_set_id;
      fl.section = fl.backP -> fl.section + 1;		/* increment section number */
      fl.sequence = fl.backP -> fl.sequence;
      fl.generation = fl.backP -> fl.generation;
      fl.version = fl.backP -> fl.version;
      fl.creation = fl.backP -> fl.creation;
      fl.expiration = fl.backP -> fl.expiration;
      fl.access = fl.backP -> fl.access;
      fl.blkcnt = 0;
      fl.system = fd.system;

      fl.hdr2 = fl.backP -> fl.hdr2;
      fl.next_volname, fl.canonical_next_volname = "";	/* initialize */

      return;

   end fill_new_section_fl;


handler:
   procedure;					/* intercept any faults during iocb manipulation */
dcl   1 ti		        aligned,
        2 version		        fixed bin init (0),
        2 code		        fixed bin (35);

      if mask ^= "0"b
      then
         do;					/* IPS interrupts masked */
	  ti.code = error_table_$unable_to_do_io;	/* very bad trouble */
	  call terminate_process_ ("fatal_error", addr (ti));
						/* kill the process */
         end;
      call continue_to_signal_ (0);
      return;
   end handler;

initialize_permit:
   procedure (vX) returns (bit (1));			/* query for permission to write VOL1 label */
dcl   vX			        fixed bin;
dcl   msg			        char (120) varying;
dcl   (extra1, extra2)	        char (12) varying initial ("");

      qi.scode = error_table_$uninitialized_volume;	/* set status code */
      go to query (vl (vX).write_VOL1);			/* issue appropriate query */


initialize_permitA:
   entry (vX) returns (bit (1));			/* query to initialize an unexpired volume */
      qi.qcode = 0;
      qi.scode = error_table_$unexpired_volume;
      msg = "Volume ^a requires initialization, but contains an unexpired file.^/Do you want to initialize it?";
      go to ip_com;


query (2):
      qi.qcode = 1;					/* unreadable 1st block */
      msg = "Volume ^a requires initialization: first block is unreadable.^/Do you want to initialize it?";
      go to ip_com;


query (3):
      qi.qcode = 2;					/* first block isn't VOL1 label */
      msg = "Volume ^a requires initialization: first block is not VOL1 label.^/Do you want to initialize it?";
      go to ip_com;


query (4):
      qi.qcode = 3;					/* VOL1 label has wrong volid */
      extra1 = substr (cseg.lbl_buf, 5, 6);		/* volid encountered */
      extra2 = vl (vX).canonical_volname;		/* volid expected */
      msg = "Warning: Label for volume ^a contains identifier ^a instead of ^a.^/";
      if cseg.open_mode = 4
      then /* Volume is read-only */
	 msg = msg || "Do you really want to continue processing?";
      else msg = msg || "Do you want to reinitialize it as the desired volume?";
						/* can write to the tape */
      go to ip_com;


query (5):
      qi.qcode = 4;					/* VOL1 label correct, but wrong density */
      msg = "Volume ^a requires initialization: recorded at incorrect density.^/Do you want to re-initialize it?";
      go to ip_com;

query (6):
      qi.qcode = 5;					/* VOL1 label correct, but invalid file-set format */
      msg =
         "Volume ^a requires initialization: recorded in an invalid file-set format.^/Do you want to re-initialize it?";


ip_com:
      qi.yes_no = "1"b;
      qi.suppress_name = "0"b;

      call command_query_ (addr (qi), answer, cseg.module, (msg), vl (vX).volname, extra1, extra2);

      if answer = "yes"
      then return ("1"b);
      else return ("0"b);

   end initialize_permit;

initialize_volume:
   procedure (vX, ecode);				/* initializes a volume with VOL1 label and 1 dummy file */
dcl   vX			        fixed bin,		/* volume link index */
      ecode		        fixed bin (35);	/* error code */
dcl   (i, j, k)		        fixed bin;		/* temporary indices */

      if debug
      then call debug_print ("initialize_volume");

      vl (vX).auth_code = authenticate_ (vl (vX).volname);

      vl (vX).cflX = 0;
      call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);	/* get to beginning of tape */
      if ecode ^= 0
      then return;

      ansi_vol1P, ibm_vol1P = addr (cseg.lbl_buf);	/* get pointer to label buffer */
      ansi_vol1.label_id = "VOL1";			/* initialize VOL1 label */
      ansi_vol1.volume_id = vl (vX).canonical_volname;

      if cseg.standard = 1
      then
         do;					/* ANSI */
	  ansi_vol1.access = " ";
	  ansi_vol1.reserved1 = " ";
	  ansi_vol1.owner_id = vl (vX).auth_code;
	  ansi_vol1.reserved2 = " ";
	  ansi_vol1.label_version = "3";
	  k = 2;					/* set HDR loop limit */
         end;
      else
         do;					/* IBM */
	  ibm_vol1.reserved1 = "0";
	  ibm_vol1.VTOC_pointer = " ";
	  ibm_vol1.reserved2 = " ";
	  ibm_vol1.owner_id = vl (vX).auth_code;
	  ibm_vol1.reserved3 = " ";
	  k = 1;					/* set HDR loop limit */
         end;

      call write_label (ecode);			/* write VOL1 label */
      if ecode ^= 0
      then return;

      do i = 1 to k;
         cseg.lbl_buf = l1id (i) || dummy_label (k);
         call write_label (ecode);			/* write HDR1 / EOF1 label */
         if ecode ^= 0
         then return;
         do j = 1 to 2;
	  call tape_ansi_tape_io_$order (cP, "eof", 0, ecode);
						/* write 2 TM */
	  if ecode ^= 0
	  then return;
         end;
      end;

      return;

   end initialize_volume;

lrec_open:
   procedure;					/* logical record IO initialization and final checks */
      if debug
      then call debug_print ("lrec_open");
dcl   i			        fixed bin;

      if cseg.open_mode > 4
      then if fd.blklen < 18
	 then go to inv_blk;			/* can't write < 18 chars */
      if fd.mode = 3
      then cseg.mode = 0;				/* binary encoding   */
      else cseg.mode = 1;				/* ascii, ebcdic 9 mode hardware */
      if cseg.standard > 1
      then go to ibm_open;

      i = fd.blklen - fd.bo;				/* get usable portion of block */
      go to test (fd.format);				/* test the blocking */
test (2):
      if ^fd.blocked
      then if i ^= fd.reclen
	 then go to inv_rec;			/* F unblocked */
	 else go to ok;
      else if mod (i, fd.reclen) ^= 0
      then go to inv_rec;				/* F blocked */
      else go to ok;
test (3):
      if ^fd.blocked
      then if i ^= fd.reclen
	 then go to inv_rec;			/* D unblocked */
	 else go to ok;
      else if fd.reclen > i
      then go to inv_rec;				/* D blocked */
      else go to ok;
test (4):
match (4):
      if fd.reclen > sys_info$max_seg_size * 4
      then go to inv_rec;				/* S format */

test (1):
match (1):
ok:
      cseg.rlN = -1;				/* invalidate anything in rl segment */
      cseg.lrec.bufP = null;				/* no active buffer */
      if cseg.open_mode = 4
      then cseg.lrec.blkcnt = 0;			/* input - no blocks processed */
      else cseg.lrec.blkcnt = fl.blkcnt;		/* output - set to 0 or EOX blkcnt for extend */
      cseg.lrec.reccnt = 0;				/* not currently used */
      cseg.lrec.code = 0;				/* no errors encountered */
      call tape_ansi_tape_io_$open (cP);		/* initialize call to tape_ansi_tape_io_ */
      return;					/* exit */

inv_rec:
      code = error_table_$invalid_record_length;
      go to er_exit;
inv_blk:
      code = error_table_$invalid_block_length;		/* set error code */
      go to er_exit;

ibm_open:
      if cseg.open_mode > 4
      then if mod (fd.blklen, 4) ^= 0
	 then go to inv_blk;			/* can only write words */


      go to match (fd.format);			/* match the blocking */
match (2):
      if ^fd.blocked
      then if fd.blklen ^= fd.reclen
	 then go to inv_rec;			/* F unblocked */
	 else go to ok;
      else if mod (fd.blklen, fd.reclen) ^= 0
      then go to inv_rec;				/* F blocked */
      else go to ok;
match (3):
      if ^fd.blocked
      then if fd.blklen - 4 ^= fd.reclen
	 then go to inv_rec;
	 else go to ok;
      else if fd.reclen > fd.blklen - 4
      then go to inv_rec;				/* V blocked */
      else go to ok;

   end lrec_open;

move_to_EOD:
   procedure;					/* position after last data block of last section */

      if debug
      then call debug_print ("move_to_EOD");
      do cseg.flP = cseg.flP repeat fl.nextP while (fl.eox = 2);
						/* set link pointer to last section */
      end;

      call move_tape_ (fl.vlX, fl.flX, 2, code);		/* move to trailers */
      if code ^= 0
      then go to er_exit;

      call back_TM (1, code);				/* move back into data */
      if code ^= 0
      then go to er_exit;

      return;

   end move_to_EOD;

move_tape_:
   procedure (vX, fX, posit, ecode);			/* positions to file section and intra-section position */
dcl   vX			        fixed bin,		/* volume link index of desired volume */
      fX			        fixed bin,		/* file link index of desired file */
      posit		        fixed bin,		/* position within file section */
      ecode		        fixed bin (35);	/* error code */
dcl   (i, j)		        fixed bin,
      can_retry		        bit (1) init ("0"b);
dcl   uninit_msg		        (6) char (40)
			        init ("is blank", "is unreadable", "is not formatted according to standard",
			        "has volume identifier of", "is recorded at incorrect density",
			        "is recorded in invalid file-set format");

      if debug
      then call debug_print ("move_tape_");
      if vl (vX).rcp_id = 0
      then
         do;					/* volume is not mounted */
	  if cseg.nactive < cseg.ndrives
	  then
	     do;					/* more drives available */
	        call tape_ansi_mount_cntl_$mount (cP, vX, ecode);
						/* mount the volume */
	        if ecode ^= 0
	        then
		 do;				/* maybe trouble */
		    if ecode = error_table_$device_limit_exceeded
		    then
		       do;
			cseg.ndrives = cseg.ndrives - 1;
						/* decrement maximum device count */
			go to switch;
		       end;
		    else go to error;		/* true trouble */
		 end;
	     end;
	  else
	     do;					/* no drive available */
switch:
	        call find_candidate;			/* get index (i) of volume to dismount */
	        call tape_ansi_mount_cntl_$remount (cP, i, vX, ecode);
						/* remount the volume */
	        if ecode ^= 0
	        then go to error;			/* trouble */
	     end;
         end;

      cseg.tseg.drive_name = vl (vX).tape_drive;
      cseg.tseg.ev_chan = vl (vX).event_chan;

      if cseg.open_mode = 4
      then /* open for read only */
	 vl (vX).write_VOL1 = max (vl (vX).write_VOL1, 0);/* bide time; don't try to update label now */

      if vl (vX).write_VOL1 ^= 0
      then
         do;					/* VOL1 label missing or bad */
	  if (cseg.open_mode = 4) /* mounted read-only */ & (vl (vX).write_VOL1 ^= 4)
						/* and not just mismatched volid */
	  then
	     do;					/* volume needs relabeling and can't */
uninit_error:
	        call ioa_ ("^a: Volume ^a ^a.", cseg.module, vl (vX).volname, uninit_msg (vl (vX).write_VOL1));
	        ecode = error_table_$uninitialized_volume;
	        go to error;
	     end;

	  if vX = 1 & ^creating_first ()
	  then if vl (vX).write_VOL1 < 0
	       then vl (vX).write_VOL1 = 0;		/* bide time, etc. */
	       else go to uninit_error;		/* don't init 1st vol if not creating 1st file */

	  if vl (vX).write_VOL1 > 1
	  then if ^initialize_permit (vX)
	       then
		do;				/* tape isn't blank - no permission */
		   ecode = error_table_$uninitialized_volume;
		   go to error;
		end;

	  if vl (vX).write_VOL1 ^= 0
	  then /* needs better VOL1 label */
	       if cseg.open_mode ^= 4
	       then
		do;				/* don't do if read only-- if we're here, */
						/* problem is insignificant anyway */
		   call initialize_volume (vX, ecode);
		   if ecode ^= 0
		   then go to error;
		end;

	  vl (vX).write_VOL1 = 0;			/* VOL1 written - cflX = 0 */
         end;

      can_retry = "1"b;				/* one retry permitted */
      if vl (vX).cflX = 0
      then
         do;					/* volume position unknown or in VOL/UVL set */
retry:
	  call move_to_first_HDR;			/* position tape to 1st_HDR HDR group */
	  vl (vX).cflX = vl (vX).fflX;		/* volume positioned to 1st file section */
	  vl (vX).pos = 0;
         end;

      if vl (vX).cflX < fX
      then
         do;					/* volume positioned before desired file */
	  j = (fX - vl (vX).cflX) * 3;		/* move over TM's */
	  j = j - vl (vX).pos + posit;		/* adjust for intra-file offsets */
	  call move_forward;			/* move j TM */
         end;

      else if vl (vX).cflX > fX
      then
         do;					/* volume positioned after desired file */
	  j = ((vl (vX).cflX - fX) * 3) + 1;		/* move over TM's */
	  j = j + vl (vX).pos - posit;		/* adjust for intra-file offsets */
	  call move_backward;			/* move j TM */
         end;

      else
         do;					/* volume positioned at desired file */
	  if vl (vX).pos = posit
	  then
	     do;					/* and at desired offset */
	        j = 1;				/* really positions to 1st block after this TM */
	        call move_backward;			/* really positions to beginning of TM group */
	     end;
	  else if vl (vX).pos < posit
	  then
	     do;					/* before desired offset */
	        j = posit - vl (vX).pos;
	        call move_forward;			/* move j TM */
	     end;
	  else
	     do;					/* after desired section */
	        j = vl (vX).pos - posit + 1;		/* move over TM's */
	        call move_backward;			/* move j TM */
	     end;
         end;

ok_exit:
      vl (vX).cflX = fX;				/* new position info */
      vl (vX).pos = posit;
      return;

error:
      vl (vX).cflX = 0;				/* we don't know where we are */
      if can_retry
      then
         do;					/* can we retry the move? */
	  can_retry = "0"b;				/* yes - but only once */
	  go to retry;
         end;
      return;

find_candidate:
   procedure;					/* find a volume to dismount */
      if debug
      then call debug_print ("find_candidate");

      do i = 1 to vX - 1;				/* search up to desired volume */
         if vl (i).rcp_id ^= 0
         then return;				/* got one active */
      end;					/* none preceding current link */
      do i = cseg.vcN to vX + 1 by -1;			/* search down to desired volume */
         if vl (i).rcp_id ^= 0
         then return;				/* got one active */
      end;
      ecode = error_table_$invalid_cseg;		/* something very wrong if no volume found */
      go to error;

   end find_candidate;

move_to_first_HDR:
   procedure;					/* positions volume to 1st HDR label */
      if debug
      then call debug_print ("move_to_first_HDR");

      call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);	/* rewind the volume */
      if ecode ^= 0
      then go to error;
HDR_search:
      call read_label (ecode);			/* read a label */
      if ecode ^= 0
      then
         do;					/* trouble */
	  if ecode = error_table_$eof_record
	  then ecode = error_table_$invalid_file_set_format;
	  go to error;
         end;
      if label_type ^= "HDR"
      then go to HDR_search;				/* read until 1st HDR */
      call tape_ansi_tape_io_$order (cP, "bsr", 0, ecode);	/* get back to beginning of HDR */
      if ecode ^= 0
      then go to error;
      return;

move_forward:
   entry;						/* position j TM sections forward */
      do i = 1 to j;
         call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
						/* move forward 1 TM */
         if ecode ^= 0
         then go to error;
      end;
      return;

move_backward:
   entry;						/* position j TM sections backward */
      do i = 1 to j - 1;				/* do all but last */
         call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
						/* backspace 1 TM */
         if ecode ^= 0
         then go to error;
      end;

      call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);	/* do last */
      if ecode = error_table_$positioned_on_bot
      then go to HDR_search;
      else if ecode ^= 0
      then go to error;
      call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);	/* position to record after TM */
      if ecode ^= 0
      then go to error;
      return;

move_to_first_UHL:
   entry;						/* position to 1st UHL */
      i = 1;
      go to UL_search;
move_to_first_UTL:
   entry;						/* position to 1st UTL */
      i = 2;
UL_search:
      call read_label (ecode);			/* read a label */
      if ecode = error_table_$eof_record
      then call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
						/* EOF */
      else if ecode ^= 0
      then go to error;
      else if label_type ^= UL (i)
      then go to UL_search;				/* not a user label */
      else call tape_ansi_tape_io_$order (cP, "bsr", 0, ecode);
						/* got it */
      if ecode ^= 0
      then go to error;
      return;

   end move_to_first_HDR;

   end move_tape_;

next_volume:
   procedure returns (bit (1));			/* determines if volume switch possible */

dcl   canon_std		        (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);

      if debug
      then call debug_print ("next_volume");

      if fl.vlX < cseg.vcN
      then return ("1"b);				/* if current vlX < vcN then next exists */

      if fl.vlX = 63
      then
         do;					/* volume chain full */
	  call ioa_ ("^a: Implementation limit of 63 volumes exceeded.", cseg.module);
	  return ("0"b);
         end;

      if fl.system = fd.system
      then
         do;					/* trailers could have next reel id */
	  if fl.next_volname ^= ""
	  then
	     do;					/* they do */
	        vn = fl.next_volname;			/* copy it */
	        go to got_volname;			/* use it */
	     end;
         end;

      if another_volume ()
      then vl (cseg.vcN + 1).comment = com_text;		/* yes */
      else return ("0"b);				/* no */

got_volname:
      cseg.vcN = cseg.vcN + 1;			/* increment volume link count */
      call vl_init (cseg.vcN);
      vl (cseg.vcN).volname = vn;			/* set reel id in volume link */
      call
         canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (cseg.vcN).volname, vl (cseg.vcN).canonical_volname,
         canon_std (cseg.standard), code);
      if code ^= 0
      then return ("0"b);

      return ("1"b);

   end next_volume;

process_EOX:
   procedure (ecode);				/* processes trailer labels for file chain */
dcl   ecode		        fixed bin (35);

dcl   canon_std		        (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);

      if debug
      then call debug_print ("process_EOX");
      on conversion go to bad_EOX;
      fl.eox = 0;					/* trailers not yet processed */
      ansi_hdr1P, ansi_hdr2P = addr (lbl_buf);		/* set pointers to label IO buffer */

      call read_label (ecode);			/* read EOX1 label */

      if ecode ^= 0
      then
         do;					/* trouble */
	  if ecode = error_table_$eof_record
	  then /* label missing */
bad:
	     ecode = error_table_$invalid_file_set_format;
	  return;
         end;

      if ansi_hdr1.label_id = "EOV1"
      then fl.eox = 2;				/* indicate volume switch */
      else if ansi_hdr1.label_id = "EOF1"
      then fl.eox = 1;				/* no volume switch */
      else go to bad;				/* error if not EOF or EOV */

      fl.creation = substr (ansi_hdr1.creation, 2, 5);	/* update creation date to latest */

      fl.version = fixed (ansi_hdr1.version, 17);		/* update version to latest */

      fl.blkcnt = fixed (ansi_hdr1.blkcnt, 35);		/* save block count */

      call read_label (ecode);			/* read next label (EOX2 or otherwise) */

      if ecode ^= 0
      then
         do;					/* investigate */
	  if ecode = error_table_$eof_record
	  then
	     do;					/* no EOX2 label */
	        call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
						/* backspace into trailer set */
	        if ecode ^= 0
	        then return;
no_EOX2:
	        if fl.eox = 2
	        then
		 do;				/* EOV label */
		    if next_volume ()
		    then fl.next_volname = vl (fl.vlX + 1).volname;
						/* have volume */
		    else ecode = error_table_$no_next_volume;
		 end;
	     end;
	  return;
         end;

      if label_type = "UTL"
      then go to no_EOX2;				/* user label - no EOX2 */
      if ansi_hdr2.label_id ^= l2id (fl.eox + 1)
      then go to bad;				/* label not EOF2 or EOV2 */

      if fl.eox = 2
      then
         do;					/* EOV labels */
	  if cseg.standard = 1
	  then if fl.system = fd.system
	       then if old_ansi_hdr2_system_use.system_reserved ^= ""
		  then
		     do;
		        fl.next_volname = ansi_hdr2.next_volname;
		        call
			 canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), fl.next_volname,
			 fl.canonical_next_volname, canon_std (cseg.standard), ecode);
		        if ecode ^= 0
		        then goto bad_EOX;
		     end;

	  if next_volume ()
	  then
	     do;					/* allow for -volume override */
	        fl.next_volname = vl (fl.vlX + 1).volname;
	        fl.canonical_next_volname = vl (fl.vlX + 1).canonical_volname;
	     end;
	  else ecode = error_table_$no_next_volume;
         end;

      return;

bad_EOX:
      ecode = error_table_$invalid_label_format;
      return;

   end process_EOX;

read_HDR1:
   procedure (eofsw, ecode);				/* read HDR1 label (if any) */
dcl   eofsw		        bit (1);		/* end-of-file-set bit */
dcl   ecode		        fixed bin (35);

      if debug
      then call debug_print ("read_HDR1");
      eofsw = "0"b;					/* initialize */
      ansi_hdr1P, ibm_hdr1P = addr (cseg.lbl_buf);	/* set pointer to label */

      call read_label (ecode);			/* read it */

      if ecode = 0
      then
         do;					/* read something ok */
	  if ansi_hdr1.label_id ^= "HDR1"
	  then
	     do;					/* the something wasn't what we wanted */
	        ecode = error_table_$invalid_file_set_format;
	        return;
	     end;
         end;

      else if ecode = error_table_$eof_record
      then
         do;					/* read a TM */
	  vl (fl.vlX).pos = vl (fl.vlX).pos + 1;	/* increment position count */
	  call back_TM (1, ecode);			/* backup over it */
	  if ecode = 0
	  then eofsw = "1"b;			/* set the eofs bit */
         end;

      return;

   end read_HDR1;


read_HDR2:
   procedure (ecode);				/* read HDR2 label (if any) */
dcl   ecode		        fixed bin (35);

      if debug
      then call debug_print ("read_HDR2");
      fl.HDR2 = "0"b;				/* HDR2 not yet processed */
      ansi_hdr2P, ibm_hdr2P = addr (cseg.lbl_buf);	/* get pointer to label */

      call read_label (ecode);			/* read it */

      if ecode = 0
      then
         do;					/* read something ok */
	  if ansi_hdr2.label_id = "HDR2"
	  then fl.HDR2 = "1"b;			/* something was HDR2 */
	  else ;					/* something wasn't */
         end;

      else if ecode = error_table_$eof_record
      then
         do;					/* went over TM */
	  vl (fl.vlX).pos = vl (fl.vlX).pos + 1;	/*  increment position count */
	  call back_TM (1, ecode);			/* backup over it */
         end;

      return;

   end read_HDR2;

read_label:
   procedure (ecode);				/* reads an 80 character label synchronously */
dcl   ecode		        fixed bin (35),
      nchar		        fixed bin;

      call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read a block */

      if ecode = 0
      then
         do;					/* read was uneventful */
	  if nchar < 80
	  then
	     do;					/* definitely not a label */
	        ecode = error_table_$invalid_label_format;
	        return;
	     end;
	  else
	     do;					/* probably a label */
	        if cseg.standard = 1
	        then cseg.lbl_buf = sync_buf;		/* move into label buffer */
	        else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf);
						/* convert to ascii and move */
	     end;
         end;

      if debug
      then
         do;
	  if ecode = 0
	  then call ioa_ ("^80a", lbl_buf);
	  else call ioa_ ("^d", ecode);
         end;
      return;					/* with ecode = 0, EOF, or error */


write_label:
   entry (ecode);

      if cseg.standard = 1
      then sync_buf = cseg.lbl_buf;			/* ascii - move it */
      else call ascii_to_ebcdic_ (cseg.lbl_buf, sync_buf);	/* ebcdic - convert and move */

      call tape_ansi_tape_io_$sync_write (cP, 80, ecode);	/* write it */

      if debug
      then call ioa_ ("^d^-^80a", ecode, lbl_buf);
      return;					/* with ecode = 0, EOT, or error */

   end read_label;

setup_for_create:
   procedure;					/* fills file link from file data (mostly) */
      if debug
      then call debug_print ("setup_for_create");

      fl.file_id = fd.file_id;			/* use creation name */
      fl.set_id = fl.backP -> fl.set_id;
      fl.canonical_set_id = fl.backP -> fl.canonical_set_id;
      fl.section = 1;
      fl.sequence = fd.sequence;
      if cseg.standard = 1
      then fl.generation = 1;
      else fl.generation = 0;
      fl.version = 0;
      fl.creation = fd.creation;
      fl.expiration = fd.expiration;
      fl.access = fd.access;
      fl.blkcnt = 0;
      fl.system = fd.system;

      call fill_flhdr2_from_fd;			/* fill fl HDR2 from fd and defaults */

      return;

   end setup_for_create;


setup_for_extend_modify:
   procedure;					/* fills file data from file link */
      if debug
      then call ioa_ ("setup_for_extend_modify");

      fd.file_id = fl.file_id;			/* copy HDR1 data */
      fd.sequence = fl.sequence;
      if cseg.standard = 1
      then fl.version = mod (fl.version + 1, 100);	/* if ANSI, up version */
      fl.creation = fd.creation;
      if cseg.output_mode = 2
      then fl.blkcnt = 0;				/* zero block count for modify */
      else ;					/* maintain block count for extend */

      call fill_fdhdr2_from_fl;			/* put hdr2 data from fl, if any, into fd */
      call fill_flhdr2_from_fd;			/* put fd hdr2 data into fl, _n_o defaults */

      return;

   end setup_for_extend_modify;

setup_for_read:
   procedure;					/* tries to complete file data from file link on input */
      if debug
      then call debug_print ("setup_for_read");

      fd.file_id = fl.file_id;			/* copy HDR1 data */
      fd.sequence = fl.sequence;

      if fd.format = 0
      then
         do;					/* no explicit format */
	  fd.format = fl.format;
	  if fd.format = 0
	  then
	     do;
not_enough:
	        code = error_table_$insufficient_open;
	        go to er_exit;
	     end;
	  format_override = "0"b;			/* file data does not override link data */
         end;
      else format_override = "1"b;			/* explicit format */

      if fd.blklen = 0
      then fd.blklen = fl.blklen;
      if fd.blklen = 0
      then go to not_enough;

      if fd.reclen = 0
      then fd.reclen = fl.reclen;
      if fd.reclen = 0
      then
         do;					/* this may be valid */
	  if fd.format = 4
	  then fd.reclen = sys_info$max_seg_size * 4;	/* S or V(B)S */
	  else if fd.format = 1
	  then ;					/* U format - reclen undefined */
	  else go to not_enough;
         end;

      if cseg.standard = 1
      then
         do;					/* ANSI */
	  if fl.system ^= ""
	  then fd.bo = fl.bo;			/* set buffer offset if HDR1 has it */
	  if fl.system = fd.system
	  then
	     do;					/* file written by this system? */
	        if ^format_override
	        then fd.blocked = fl.blocked;		/* set blocked attribute from labels */
	        if fd.mode = 0
	        then fd.mode = fl.mode;		/* set encoding mode from labels */
	     end;
	  else
	     do;					/* system-defined fields are invalid - apply defaults */
	        if ^format_override
	        then fd.blocked = "1"b;		/* blocked */
	        if fd.mode = 0
	        then fd.mode = 1;			/* ascii */
	     end;
         end;
      else
         do;					/* IBM */
	  if ^format_override
	  then fd.blocked = fl.blocked;
	  if fd.mode = 0
	  then fd.mode = 2;				/* EBCDIC */
         end;

      return;

   end setup_for_read;

setup_for_generate:
   procedure;					/* updates file link and fills file data */
      if debug
      then call debug_print ("setup_for_generate");

      fd.file_id = fl.file_id;
      fd.sequence = fl.sequence;

      fl.generation = mod (fl.generation + 1, 10000);	/* increment generation number */
      fl.version = 0;
      fl.creation = fd.creation;			/* use today's date */
      fl.expiration = fd.expiration;			/* use specified expiration date */
      fl.access = fd.access;
      fl.blkcnt = 0;

      call fill_fdhdr2_from_fl;			/* put fl hdr2 data, if any, into fd */
      call fill_flhdr2_from_fd;			/* put fd hdr2 data into fl, _n_o defaults */

      fl.system = fd.system;				/* set now to use system-defined HDR2 fields */

      return;

   end setup_for_generate;

truncate_chains:
   procedure;					/* eliminate chain references to overwritten files */
      if debug
      then call debug_print ("truncate_chains");

dcl   i			        fixed bin,		/* temporary index into volume chain */
      saveP		        ptr,		/* holds pointer to desired file link */
      zaP			        ptr;		/* file chain truncation pointer */

      if fl.nextP = null
      then return;					/* nothing to truncate */

      on cleanup
         begin;					/* don't leave chains inconsistent */
	  cseg.fcP -> fl.nextP = null;		/* truncate file chain entirely (leave dummy) */
	  do i = 1 to cseg.vcN;			/* wipe the volume chain clean of file link references */
	     vl (i).fflX = 0;
	     vl (i).cflX = 0;
	     vl (i).lflX = 0;
	  end;
         end;

      saveP = cseg.flP;				/* save pointer to desired file link */
      cseg.flP = fl.nextP;				/* begin truncation after current link */
      fl.backP -> fl.nextP = null;			/* step 1 - file chain logically truncated */
      if fl.flX = -1
      then go to free;				/* only truncate an eofsl */

      if vl (fl.vlX).fflX = fl.flX
      then
         do;					/* truncated files start a volume */
	  vl (fl.vlX).fflX = 0;			/* wipe that volume clean */
	  vl (fl.vlX).cflX = 0;
	  vl (fl.vlX).lflX = 0;
         end;
      else vl (fl.vlX).lflX = fl.flX - 1;		/* or, last valid reference is before truncation point */

      do i = fl.vlX + 1 to cseg.vcN;			/* all subsequent volumes must be emptied */
         vl (i).fflX = 0;
         vl (i).cflX = 0;
         vl (i).lflX = 0;
      end;					/* step 2 - volume chain adjusted */

      revert cleanup;				/* drastic measures no longer needed */

free:
      zaP = cseg.flP;				/* set pointer to truncation point */
      do cseg.flP = cseg.flP repeat zaP while (zaP ^= null);/* step 3 - free file chain storage */
         zaP = fl.nextP;				/* set pointer to next truncation point */
         free fl in (chain_area);			/* free link at current truncation point */
      end;

exit:
      cseg.flP = saveP;				/* restore pointer to last valid link */

      return;

   end truncate_chains;

vl_init:
   procedure (n);					/* initialize a volume link */
dcl   n			        fixed bin;		/* link index */
      vl (n).fflX = 0;
      vl (n).cflX = 0;
      vl (n).pos = 0;
      vl (n).lflX = 0;
      vl (n).tracks = 0;
      vl (n).density = 0;
      vl (n).label_type = 0;
      vl (n).usage_count = 0;
      vl (n).read_errors = 0;
      vl (n).write_errors = 0;
      vl (n).rcp_id = 0;
      vl (n).event_chan = 0;
      vl (n).tape_drive = "";
      vl (n).write_VOL1 = 0;
      vl (n).ioi_index = 0;
      return;
   end vl_init;

write_HDRs:
   procedure (ecode);				/* formats and writes HDR1 and HDR2 */
      if debug
      then call debug_print ("write_HDRs");

dcl   ecode		        fixed bin (35);	/* error code */
dcl   x			        fixed bin;		/* entry index */

      fl.eox = 0;					/* trailers not yet written */
      x = 1;
      go to write_labels;

write_EOFs:
   entry (ecode);					/* formats and writes EOF1 and EOF2 */
      if debug
      then call debug_print ("write_EOFs");
      fl.blkcnt = cseg.blkcnt;			/* update block count */
      fl.eox = 1;					/* no volume switch */
      x = 2;
      go to write_labels;

write_EOVs:
   entry (ecode);					/* formats and writes EOV1 and EOV2 */
      if debug
      then call debug_print ("write_EOVs");
      fl.blkcnt = cseg.blkcnt;			/* update block count */
      fl.eox = 2;					/* volume switch */
      x = 3;

write_labels:
      call fill_XXX1 (x);				/* format label as HDR1, EOF1, or EOV1 */
      call write_label (ecode);			/* write it */
      if ecode ^= 0
      then if ecode ^= error_table_$eov_on_write
	 then return;				/* check error code */

      if x = 1
      then fl.HDR2 = "1"b;				/* request is for headers, so HDR2 exists */
      else
         do;					/* request is for trailers */
	  if ^fl.HDR2
	  then
	     do;					/* no HDR2 label */
	        ecode = 0;				/* therefore, no EOX2 label */
	        return;
	     end;
         end;

      call fill_XXX2 (x);				/* format label as HDR2, EOF2, or EOV2 */
      call write_label (ecode);			/* write it */
      if ecode = error_table_$eov_on_write
      then ecode = 0;				/* ignore EOT */

      return;					/* with ecode = 0 or an error code */

   end write_HDRs;

write_TM:
   procedure (n, ecode);				/* writes 1 or 2 TM and adjusts volume link */
dcl   n			        fixed bin,		/* number of TM - 1 or 2 */
      cnt			        fixed bin,
      ecode		        fixed bin (35);

      if debug
      then call ioa_ ("write_TM ^d", n);
      do cnt = 1 to n;				/* 1 or 2 */
         call tape_ansi_tape_io_$order (cP, "eof", 0, ecode);
						/* write a TM */
         if ecode ^= 0
         then if ecode ^= error_table_$eov_on_write
	    then return;				/* error exit */

         vl (fl.vlX).pos = vl (fl.vlX).pos + 1;		/* increment for each TM */
         if vl (fl.vlX).pos > 2
         then
	  do;					/* adjust mod3 */
	     vl (fl.vlX).pos = vl (fl.vlX).pos - 3;
	     vl (fl.vlX).cflX = vl (fl.vlX).cflX + 1;
	  end;
      end;

      return;

   end write_TM;

write_new_section:
   procedure (ecode);				/* writes new section headers */
dcl   ecode		        fixed bin (35);

      if debug
      then call debug_print ("write_new_section");
      cseg.flP = fl.nextP;				/* set pointer to next (eofs) link */
      call make_eofsl_real;				/* make it a real link */

      call build_eofsl;				/* add a new end-of-file-set link */

      call move_tape_ (fl.vlX, fl.flX, 0, ecode);		/* position to write headers */
      if ecode ^= 0
      then return;					/* trouble */

      ansi_hdr1P = addr (cseg.lbl_buf);			/* set pointer to label buffer - move_tape_ read HDR1 */
      if substr (ansi_hdr1.expiration, 2, 5) > fd.creation
      then
         do;					/* volume has unexpired data */
	  if initialize_permitA (fl.vlX)
	  then
	     do;					/* user said can re-initialize */
	        call initialize_volume (fl.vlX, ecode);	/* do it */
	        if ecode ^= 0
	        then return;
	        call move_tape_ (fl.vlX, fl.flX, 0, ecode);
						/* re-position to HDR1 */
	        if ecode ^= 0
	        then return;
	     end;
	  else
	     do;					/* user said can't */
	        ecode = error_table_$unexpired_volume;
	        return;
	     end;
         end;

      call fill_new_section_fl;			/* initialize the link */

      call write_HDRs (ecode);			/* write HDR labels */
      if ecode ^= 0
      then return;

/* if cseg.user_labels then call write_UHL; */

      call write_TM (1, ecode);			/* write header set TM */

      return;

   end write_new_section;

data_eof:
   entry (iocbP, code);				/* called by lrec IO when encounters EOF */

      if debug
      then call debug_print ("data_eof");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get control segment pointer */

      cc = 0;					/* minimal consistency requirement */
      on cleanup go to data_eof_fail;
      on area
         begin;					/* handle the condition */
	  code = error_table_$noalloc;
	  go to data_eof_fail;
         end;

      vl (fl.vlX).pos = vl (fl.vlX).pos + 1;		/* have moved over a TM - update position info */

      if cseg.standard = 1
      then call tape_ansi_lrec_io_$close (cP, code);	/* close logical record IO */
      else call tape_ansi_ibm_lrec_io_$close (cP, code);
      if code ^= 0
      then
         do;
data_eof_fail:
	  call consistent;
	  go to close_exit;
         end;

      if fl.eox = 0
      then
         do;					/* trailer labels have not been processed */
	  call process_EOX (code);			/* process them */
	  if code ^= 0
	  then go to data_eof_fail;
         end;

      if cseg.blkcnt ^= -1
      then
         do;					/* block count is valid */
	  if cseg.blkcnt ^= fl.blkcnt
	  then
	     do;					/* read and recorded don't agree */
	        code = error_table_$discrepant_block_count;
	        return;
	     end;
         end;

/* if cseg.user_labels then call read_UTL */

      if fl.eox = 1
      then
         do;					/* last (or only) section */
	  code = error_table_$end_of_info;
	  return;
         end;

      if fl.nextP ^= null
      then cseg.flP = fl.nextP;			/* next link exists - use it */
      else
         do;					/* link doesn't exist - make it */
	  cc = 1;					/* insure chain consistency */
	  call build1 (code);			/* process HDR labels */
	  if code ^= 0
	  then go to data_eof_fail;
	  cc = 0;					/* minimal consistency requirement */
         end;

      if fl.flX = -1
      then
         do;					/* link is eofsl */
	  code = error_table_$invalid_file_set_format;
	  cseg.flP = fl.backP;			/* get back to last valid link */
	  go to data_eof_fail;
         end;

      if fl.file_id ^= fl.backP -> fl.file_id | /* file id's must be identical */ fl.section ^= fl.backP -> fl.section + 1
      then
         do;					/* section must be 1 > than previous */
	  code = error_table_$invalid_volume_sequence;
	  cseg.flP = fl.backP;
	  go to data_eof_fail;
         end;

/* if cseg.user_labels then call read_UHL */

      call move_tape_ (fl.vlX, fl.flX, 1, code);		/* move to data of new section */
      if code ^= 0
      then go to data_eof_fail;

      cseg.blkcnt = 0;				/* re-initialize block count for new section */

      return;

data_eot:
   entry (iocbP, code);				/* called by lrec IO when encounters EOT */

      if debug
      then call debug_print ("data_eot");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to control segment */

      cc = 2;					/* don't leave defective tape file */
      on cleanup go to write_data_fail;

eot_not_while_closing:
      close_eot = "0"b;				/* eot doing data or positioning for output */
      go to any_eot;
eot_while_closing:
      close_eot = "1"b;				/* eot writing HDR TM for null file */

any_eot:
      on area
         begin;					/* common code - EOT doing data or HDR TM */
	  code = error_table_$noalloc;
	  go to write_data_fail;
         end;

      if ^next_volume ()
      then
         do;					/* no next volume available */
	  code = error_table_$no_next_volume;
	  if ^close_eot
	  then return;				/* exit gracefully */
	  else go to write_data_fail;			/* abort the file fragment */
         end;
      else
         do;					/* volume available - set reel id in trailers */
	  fl.next_volname = vl (fl.vlX + 1).volname;
	  fl.canonical_next_volname = vl (fl.vlX + 1).canonical_volname;
         end;

/* finish current volume, switch to new file section on new volume */

      call write_TM (1, code);			/* write end-of-data TM */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then
	    do;
write_data_fail:
	       call consistent;
	       go to close_exit;			/* force close */
	    end;

      call write_EOVs (code);				/* write EOV labels */
      if code ^= 0
      then go to write_data_fail;

/* if cseg.user_labels then call write_UTL; */

      call write_TM (2, code);			/* write trailer and end of volume TMs */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then go to write_data_fail;

      call write_new_section (code);			/* begin new file section */
      if code ^= 0
      then go to write_data_fail;

      cseg.lrec.blkcnt = 0;				/* initialize block count for new section */

      if close_eot
      then go to continue_close;			/* finish the close operation */
      else return;

position_for_output:
   entry (iocbP, code);				/* called by 1st write_record to write HDR TM */

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to control segment */
      if debug
      then call debug_print ("position_for_output");

      cc = 2;					/* don't leave defective tape file */
      on cleanup go to write_data_fail;

/* if cseg.user_labels then call write_UHL; */

      call write_TM (1, code);			/* write HDR TM */

      if code = 0
      then return;					/* fine - not even end-of-tape */
      if code = error_table_$eov_on_write
      then go to eot_not_while_closing;			/* end-of-tape */
      go to write_data_fail;				/* trouble */



beginning_of_file:
   entry (iocbP, code);				/* positions to beginning of file */

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to control segment */

      cc = 0;					/* minimal consistency requirement */
      on cleanup go to bof_fail;

      if cseg.standard = 1
      then call tape_ansi_lrec_io_$close (cP, code);	/* close logical record I/O */
      else call tape_ansi_ibm_lrec_io_$close (cP, code);
      if code ^= 0
      then go to bof_fail;

      do cseg.flP = cseg.flP repeat fl.backP while (fl.section ^= 1);
						/* get back to first file section */
      end;

      call move_tape_ (fl.vlX, fl.flX, 1, code);		/* position to 1st data record */
      if code ^= 0
      then
         do;					/* trouble - maintain consistency */
bof_fail:
	  call consistent;
	  go to close_exit;
         end;

      call lrec_open;				/* open logical record I/O */
						/* note: no error can occur */

      return;

end_of_file:
   entry (iocbP, code);				/* positions to end of file */

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get control segment pointer */

      cc = 0;					/* minimal consistency requirement */
      on cleanup go to eof_fail;
      on area go to eof_fail;

      if cseg.standard = 1
      then call tape_ansi_lrec_io_$close (cP, code);	/* close logical record IO */
      else call tape_ansi_ibm_lrec_io_$close (cP, code);
      if code ^= 0
      then
         do;
eof_fail:
	  call consistent;
	  go to close_exit;
         end;

      cseg.rlN = -1;				/* invalidate read_length buffer */
      cseg.blkcnt = -1;				/* invalidate block count */

eof_loop:
      if fl.eox = 0
      then
         do;					/* trailer labels have not been processed */
	  call build2 (code);			/* process them */
	  if code ^= 0
	  then go to eof_fail;
         end;

      if fl.eox = 1
      then
         do;					/* last (or only) section */
	  call move_tape_ (fl.vlX, fl.flX, 2, code);	/* position to trailers */
	  if code ^= 0
	  then go to eof_fail;
	  call back_TM (1, code);			/* get back into data */
	  if code ^= 0
	  then go to eof_fail;
	  return;
         end;

      if fl.nextP ^= null
      then cseg.flP = fl.nextP;			/* next link exists - use it */
      else
         do;					/* link doesn't exist - make it */
	  cc = 1;					/* insure chain consistency */
	  call build1 (code);			/* process HDR labels */
	  if code ^= 0
	  then go to eof_fail;
	  cc = 0;					/* minimal consistency requirement */
         end;

      if fl.flX = -1
      then
         do;					/* link is eofsl */
	  code = error_table_$invalid_file_set_format;
	  cseg.flP = fl.backP;			/* get back to last valid link */
	  go to eof_fail;
         end;

      if fl.file_id ^= fl.backP -> fl.file_id | /* file id's must be identical */ fl.section ^= fl.backP -> fl.section + 1
      then
         do;					/* section must be 1 > previous */
	  code = error_table_$invalid_volume_sequence;
	  cseg.flP = fl.backP;
	  go to eof_fail;
         end;
      go to eof_loop;

close:
   entry (iocbP, code);				/* iox_$close entry */

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get control segment pointer */

      if cseg.file_lock
      then
         do;					/* file in use? */
	  code = error_table_$file_busy;
	  return;
         end;
      else
         do;
	  on cleanup cseg.file_lock = "0"b;
	  cseg.file_lock = "1"b;
         end;

      if cseg.invalid
      then
         do;
	  code = error_table_$invalid_cseg;
	  on cleanup go to close_exit1;
	  go to close_exit1;
         end;

      if cseg.open_mode = 4
      then
         do;					/* input mode */
	  cc = 0;					/* minimal consistency requirement */
	  on cleanup go to close_fail;
	  if cseg.standard = 1
	  then call tape_ansi_lrec_io_$close (cP, code);	/*  close logical record IO */
	  else call tape_ansi_ibm_lrec_io_$close (cP, code);
	  if code ^= 0
	  then call consistent;
	  go to close_exit;
         end;
      else
         do;					/* output mode */
	  cc = 2;					/* don't leave defective tape file */
	  on cleanup go to close_fail;
	  if vl (fl.vlX).pos = 0
	  then
	     do;					/* still in HDRs, never wrote data */
	        call write_TM (1, code);		/* re-write HDR TM (should be after last HDR label) */
	        if code ^= 0
	        then
		 do;				/* maybe trouble */
		    if code = error_table_$eov_on_write
		    then go to eot_while_closing;	/* return to continue_close */
		    else go to close_fail;		/* real error, abort the file */
		 end;
	     end;
continue_close:
	  if cseg.standard = 1
	  then call tape_ansi_lrec_io_$close (cP, code);	/* close logical IO */
	  else call tape_ansi_ibm_lrec_io_$close (cP, code);
	  if code ^= 0
	  then
	     do;					/* maybe trouble */
	        if code ^= error_table_$eov_on_write
	        then
		 do;				/* EOT is ok */
close_fail:
		    call consistent;		/* delete the file */
		    go to close_exit;
		 end;
	     end;

	  call write_TM (1, code);			/* write the end-of-data TM */
	  if code ^= 0
	  then if code ^= error_table_$eov_on_write
	       then go to close_fail;			/* bad - ignore EOT */
	  call write_EOFs (code);			/* write trailer labels */
	  if code ^= 0
	  then go to close_fail;			/* trouble */

/* if cseg.user_labels then call write_UTL; */

	  call write_TM (2, code);			/* write trailer and end-of-volume TMs */
	  if code ^= 0
	  then
	     do;
	        if code = error_table_$eov_on_write
	        then code = 0;
	        else go to close_fail;
	     end;
         end;

close_exit:
      if cseg.close_rewind
      then
         do;					/* rewind volume at close time */
	  vl (fl.vlX).cflX = 0;			/* invalidate volume position */
	  call tape_ansi_tape_io_$order (cP, "rew", 0, 0);/* issue the order */
	  cseg.close_rewind = "0"b;			/* this is a one time switch */
         end;
close_exit1:
      mask = "0"b;
      revert cleanup;
      on any_other call handler;
      call hcs_$set_ips_mask ("0"b, mask);
      iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_file_cntl_$open;
      iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null;
      call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
      call hcs_$reset_ips_mask (mask, mask);
      cseg.file_lock = "0"b;
      return;

debug_on:
   entry;						/* turns debug switch on */
      debug = "1"b;
      return;

debug_off:
   entry;						/* truns debug switch off */
      debug = "0"b;
      return;

debug_print:
   procedure (text);				/* prints debug text */
dcl   text		        char (*);

      call ioa_ (text);
      return;

   end debug_print;


   end tape_ansi_file_cntl_;




		    tape_ansi_ibm_lrec_io_.pl1      11/04/82  1931.3rew 11/04/82  1606.0      247896



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

/*                                                        */
/*   *    *    *    *    *    *    *    *    *    *    *    *    *    */
/*                                                                    */
/*  0) Created:                                                       */
/*  1) Modified: 06/29/79 by Rick Riley                               */
/*               (to allow reading writing ibm tapes in binary mode   */
/*  2) Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes      */
/* ****************************************************************** */


tape_ansi_ibm_lrec_io_: procedure;
	return;

/* parameters */

	dcl     peel		 fixed bin,
	        hold		 char (4) varying;
	dcl     iocbP		 ptr,		/* pointer to iocb */
	        ubP		 ptr,		/* pointer to user buffer */
	        buf_len		 fixed bin (21),	/* length of user buffer */
	        rec_len		 fixed bin (21),	/* number of characters transmitted */
	        code		 fixed bin (35);

%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;

%include tape_ansi_fl;


/* based storage */
	dcl     1 BDW		 based (cseg.lrec.bufP), /* block descriptor word */
		2 length		 fixed bin (17) unaligned, /* block length */
		2 pad		 bit (18) unaligned;/* pad */
	dcl     buf		 char (cseg.buf_size) aligned based (cseg.lrec.bufP), /* one physical block */
	        data		 char (move) unaligned based, /* overlay for data move */
	        rpad		 char (1) based (addr (erp (fd.mode))); /* ASCII , BINARY, or EBCDIC space */
	dcl     1 SDW		 based (dwP),	/* segment descriptor word */
		2 length		 fixed bin (17) unaligned, /* length of segment */
		2 code		 fixed bin (8) unaligned, /* control code */
		2 pad		 bit (9) unaligned;
	dcl     1 RDW		 based (dwP),	/* V-format rdw */
		2 length		 fixed bin (17) unaligned, /* record length */
		2 pad		 bit (18) unaligned;/* pad */
	dcl     ub		 char (buf_len) unaligned based (ubP); /* user buffer overlay */

/* error codes */

	dcl
	        (error_table_$tape_error,
	        error_table_$eof_record,
	        error_table_$eov_on_write,
	        error_table_$file_busy,
	        error_table_$fatal_error,
	        error_table_$invalid_record_desc,
	        error_table_$long_record)
				 fixed bin (35) external static;

/* builtin functions */
	dcl     (addr, copy, mod, null, substr, unspec) builtin;

/* conditions */
	dcl     cleanup		 condition;

/* automatic storage */
	dcl     i			 fixed bin,	/* temporary storage */
	        csw		 bit (1) init ("0"b), /* indicates close or write_record entry */
	        total		 fixed bin (21) initial (0), /* total number of characters moved in this request */
	        move		 fixed bin initial (0), /* number of characters moved per segment/record */
	        left		 fixed bin (21),	/* number of characters remaining to be moved */
	        long_record		 bit (1) initial ("0"b), /* long record switch */
	        parity_error	 bit (1) initial ("0"b), /* parity error switch */
	        req_off		 fixed bin,	/* number of buffer characters processed by this request */
	        remain		 fixed bin,	/* number of unprocessed characters in buffer */
	        ecode		 fixed bin (35) init (0), /* temporary error code */
	        data_len		 fixed bin initial (0), /* number of characters in varying length record */
	        first_span		 bit (1) initial ("1"b); /* first segment of spanned request switch */

/* pointers */
	dcl     dwP		 ptr,		/* pointer to RDW - SDW */
	        fromP		 ptr,		/* pointer to buffer for data move */
	        toP		 ptr;		/* pointer to user buffer for data move */


/* static storage */


	dcl     1 sdw		 internal static aligned, /* SDW data */
		2 complete	 fixed bin (8) initial (0), /* complete code */
		2 initial		 fixed bin (8) initial (1), /* initial code */
		2 medial		 fixed bin (8) initial (3), /* medial code */
		2 final		 fixed bin (8) initial (2); /* final code */

	dcl     erp		 (3) bit (9) internal static initial ("000100000"b, "001000000"b, "000100000"b); /* ASCII EBCDIC BINARY record pad */

	dcl     ebcdic		 fixed bin internal static init (2);
	dcl     binary		 fixed bin internal static init (3);

	dcl     DOS		 fixed bin initial (3) internal static;

/* external procedures */


	dcl     ascii_to_ebcdic_	 ext entry (char (*), char (*)),
	        ebcdic_to_ascii_	 ext entry (char (*), char (*)),
	        tape_ansi_file_cntl_$data_eof ext entry (ptr, fixed bin (35)),
	        tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35)),
	        tape_ansi_file_cntl_$position_for_output ext entry (ptr, fixed bin (35)),
	        tape_ansi_nl_file_cntl_$data_eof ext entry (ptr, fixed bin (35)),
	        tape_ansi_nl_file_cntl_$data_eot ext entry (ptr, fixed bin (35)),
	        tape_ansi_tape_io_$close ext entry (ptr, fixed bin (35)),
	        tape_ansi_tape_io_$get_buffer ext entry (ptr, ptr, fixed bin (35)),
	        tape_ansi_tape_io_$read ext entry (ptr, ptr, fixed bin, fixed bin (35)),
	        tape_ansi_tape_io_$release_buffer ext entry (ptr, ptr, fixed bin (35)),
	        tape_ansi_tape_io_$write ext entry (ptr, ptr, fixed bin, fixed bin (35));

read_record: entry (iocbP, ubP, buf_len, rec_len, code);	/* read_record entry point */

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */

	if cseg.file_lock then do;
		rec_len = 0;
		code = error_table_$file_busy;
		return;
	     end;
	else do;
		on cleanup begin;
			cseg.file_lock = "0"b;
			cseg.code = error_table_$fatal_error;
		     end;
		cseg.file_lock = "1"b;
	     end;


	if cseg.code ^= 0 then do;			/* was there a non-restartable error? */
		code = cseg.code;			/* set return code */
		cseg.file_lock = "0"b;
		return;
	     end;

	if cseg.rlN ^= -1 then do;			/* data record is in read length segment */
		if buf_len >= cseg.rlN then do;	/* user wants as much as (or more than) we have */
			code = 0;
			move = cseg.rlN;		/* give only as much as we have */
		     end;
		else do;				/* user wants less than we have */
			code = error_table_$long_record;
			move = buf_len;		/* give what s(he) wants */
		     end;
		ubP -> data = cseg.rlP -> data;	/* move to user */
		rec_len = move;			/* indicate amount moved */
		cseg.rlN = -1;			/* read length buffer is now empty */
		cseg.lrec.reccnt = cseg.lrec.reccnt + 1;
		cseg.file_lock = "0"b;
		return;
	     end;

	go to r_format (fd.format);			/* transfer to begin processing */

r_format (1): call get_record;			/* U format - get a logical record */
	move = remain;				/* user gets all, even pad chars (if any) */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move as much as can fit */
	     end;
	req_off = remain;				/* this request processes the entire block */
	call move_to_user;				/* move data to user's buffer */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (2): call get_record;			/* get 1 record */
	if fd.reclen > remain then move = remain;	/* don't try to move more than we have */
	else move = fd.reclen;			/* move only up to 1 record's worth */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move only what can fit */
	     end;
	req_off = fd.reclen;			/* process one record */
	call move_to_user;				/* move data to user's buffer */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (3): call get_record;			/* V format - get a logical record */
	dwP = addr (substr (buf, cseg.offset + 1));	/* get pointer to rdw */
	if fd.mode ^= binary then /* if not already binary then make it  */
	     substr (unspec (RDW.length), 1, 10) = "00"b || substr (unspec (RDW.length), 2, 8);
						/* shift byte right to form valid binary value reading 9 mode */
	data_len = RDW.length - 4;			/* subtract rdw length to get data length */
	if data_len > remain - 4 then go to inv_desc;	/* block bigger than block size? */
	move = data_len;				/* move up to 1 record */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move only what can fit */
	     end;
	cseg.offset = cseg.offset + 4;		/* the rdw has been processed */
	req_off = data_len;				/* process one logical record */
	call move_to_user;				/* move data to user's buffer */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (4): call get_record;			/* VBS format - get a logical record */
	left = buf_len;				/* save request for decrementing */
r_sw_check: call process_sw;				/* process the SDW - get type and data length */
	if left >= data_len then move = data_len;	/* give user the entire segment..... */
	else do;					/* user doesn't want all the data */
		long_record = "1"b;			/* buffer < record */
		move = left;			/* move only as much as can fit */
	     end;
	call move_to_user;				/* move the data to the user's buffer */
	left = left - move;				/* keep track of remainder of request */
	if SDW.code = sdw.complete | SDW.code = sdw.final then do; /* segment is last (or only) of record */
		call read_release;			/* release it */
		go to r_count;			/* and we're done */
	     end;
	else call read_release;			/* release the record and continue */
	if left ^= 0 then do;			/* user wants more, and more segments are available */
		call get_record;			/* get the next segment */
		go to r_sw_check;			/* transfer to process the SDW/SDW, etc. ..... */
	     end;
	call skip_segments;				/* request satisfied, but more segments remain - skip them */
	long_record = "1"b;				/* buffer < record */
	go to r_count;				/* return to caller */

inv_desc: ecode = error_table_$invalid_record_desc;	/* set error code */
	go to r_exit;

r_count:	cseg.lrec.reccnt = cseg.lrec.reccnt + 1;

r_exit:	if parity_error then code = error_table_$tape_error;
	else code = ecode;
	cseg.code = code;
	if code = 0 then if long_record then code = error_table_$long_record;
	rec_len = total;				/* return total number of characters moved */
	cseg.file_lock = "0"b;
	return;					/* and return to the caller */

get_record: procedure;				/* internal procedure to get 1 logical record */
	if cseg.lrec.bufP = null then do;		/* get a block if inactive buffer */
restart:		call tape_ansi_tape_io_$read (cP, cseg.lrec.bufP, cseg.nc_buf, ecode); /* get 1 physical block */
		if ecode ^= 0 then do;		/* was there an error or EOF? */
			if ecode = error_table_$eof_record then do; /* EOF detected */
				if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eof (iocbP, ecode);
				else call tape_ansi_file_cntl_$data_eof (iocbP, ecode);
				if ecode = 0 then go to restart; /* switched to new file section */
				else go to r_exit;	/* no next volume or error */
			     end;
			else do;			/* parity or fatal error */
				if ecode = error_table_$tape_error then parity_error = "1"b; /* process the block */
				else go to r_exit;	/* fatal error - terminate processing */
			     end;
		     end;
		cseg.blkcnt = cseg.blkcnt + 1;	/* keep track of physical blocks read */
		if cseg.nc_buf > fd.blklen then cseg.nc_buf = fd.blklen; /* use only as much as wanted */
		if fd.format > 2 then do;		/* check BDW against block size if V,VB,VS,VBS format */
			if fd.mode ^= binary then
			     substr (unspec (BDW.length), 1, 10) = "00"b || substr (unspec (BDW.length), 2, 8);
						/* shift to get valid binary value when reading in 9 mode */
			if BDW.length > cseg.nc_buf then go to inv_desc; /* block is too short */
			cseg.nc_buf = BDW.length;	/* use all in block */
			cseg.offset = 4;		/* BDW has been processed */
		     end;
		else cseg.offset = 0;		/* U, F, or FB format */
	     end;
	remain = cseg.nc_buf - cseg.offset;		/* get number of characters to be processed */
	return;					/* exit */
     end get_record;

process_sw: procedure;				/* internal procedure to process SDW's */
	dwP = addr (substr (buf, cseg.offset + 1));	/* get pointer to SDW */
	if fd.mode ^= binary then /* if not already binary then  */
	     substr (unspec (SDW.length), 1, 10) = "00"b || substr (unspec (SDW.length), 2, 8);
						/* shift byte right valid binary reading 9 mode */
	if cseg.standard = DOS then substr (unspec (SDW.length), 3, 1) = "0"b; /* zero the bit if DOS */
	data_len = SDW.length - 4;			/* get length of data */
	if data_len > remain - 4 then go to inv_desc;
	if SDW.code < 0 then go to inv_desc;		/* error if type < 0 */
	if SDW.code > 3 then go to inv_desc;		/* error if type > 3 */
	cseg.offset = cseg.offset + 4;		/* SDW has been processed */
	req_off = data_len;				/* the entire segment will be processed */
	return;					/* exit */
     end process_sw;

skip_segments: procedure;				/* internal procedure to skip to beginning of spanned record */
s_get:	call get_record;				/* get a segment */
	call process_sw;				/* process its SDW */
	if SDW.code = sdw.final then do;		/* is this the final segment? */
		call read_release;			/* release it */
		return;				/* and exit */
	     end;
	call read_release;				/* release the segment */
	go to s_get;				/* get the next segment */
     end skip_segments;

move_to_user: procedure;				/* internal procedure to move data to user's buffer */
	if move = 0 then return;
	fromP = addr (substr (buf, cseg.offset + 1));	/* set pointer to data to be moved */
	toP = addr (substr (ub, total + 1));		/* set pointer to user buffer */
	if fd.mode = ebcdic then call ebcdic_to_ascii_ (fromP -> data, toP -> data);
	else toP -> data = fromP -> data;
	total = total + move;			/* sum each move */
	return;					/* exit */
     end move_to_user;

read_release: procedure;				/* internal procedure to release a record and/or block */
	cseg.offset = cseg.offset + req_off;		/* the request has been processed */
	remain = cseg.nc_buf - cseg.offset;		/* get number of characters not yet processed */
	if remain < 4 then do;			/* if so, the block may have been exhausted */
		if fd.format = 2 then if fd.reclen <= remain then return; /* another record? */
		call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* block exhausted  */
	     end;
	return;					/* exit */
     end read_release;

write_record: entry (iocbP, ubP, buf_len, code);		/* write_record entry point */

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */

	if cseg.file_lock then do;
		code = error_table_$file_busy;
		return;
	     end;
	else do;
		on cleanup begin;
			cseg.file_lock = "0"b;
			cseg.code = error_table_$fatal_error;
		     end;
		cseg.file_lock = "1"b;
	     end;

	if cseg.code ^= 0 then do;			/* was there a non-restartable error? */
		code = cseg.code;			/* set return code */
		cseg.file_lock = "0"b;
		return;
	     end;

	if ^cseg.no_labels then do;			/* only for labeled volumes */
		if vl (fl.vlX).pos ^= 1 then do;	/* not positioned for output */
			call tape_ansi_file_cntl_$position_for_output (iocbP, ecode);
			if ecode ^= 0 then go to w_exit; /* error */
		     end;
	     end;

	go to w_format (fd.format);			/* transfer to begin processing */



w_format (1): if buf_len > fd.blklen then go to w_long;	/* U format - check buf_len */
	call get_buf;				/* get a buffer */
	move = buf_len;				/* move the requested amount of data */
	req_off = buf_len;				/* number of characters to be processed */
	call move_to_buf;				/* move the data to the write buffer */
	call write_buf;				/* write one block */
	go to w_count;				/* return to caller */

w_format (2): if buf_len > fd.reclen then go to w_long;	/* F format - check buf_len validity */
	call get_buf;				/* get a buffer */
	move = buf_len;				/* transfer the request as stated */
	remain = fd.reclen - buf_len;			/* get difference between buf_len and reclen for padding */
	if remain ^= 0 then substr (buf, cseg.offset + buf_len + 1, remain) = copy (rpad, remain); /* pad the record */
	req_off = fd.reclen;			/* process one logical record */
	call move_to_buf;				/* move the data to the write buffer */
	if ^fd.blocked then call write_buf;		/* unblocked: write 1 record per block */
	else if cseg.offset = fd.blklen then call write_buf; /* blocked: write if block full */
	go to w_count;				/* return to caller */

w_format (3): data_len = buf_len + 4;			/* V format - data length = buf_len + RDW length */
	if data_len > fd.reclen then go to w_long;	/* check data_len validity */
	call get_buf;				/* get a buffer */
	if fd.blocked then if data_len > fd.blklen - cseg.offset then do; /* record won't fit in this block */
		     call write_buf;		/* write the current buffer contents */
		     call get_buf;			/* get another write buffer */
		end;				/* request validity has been verified, so just continue */
	dwP = addr (substr (buf, cseg.offset + 1));	/* locate rdw position */
	cseg.saveP = dwP;				/* save the RDW location for pad incrementing */
	RDW.length = data_len;			/* store the record length */
	if fd.mode ^= binary then /* if not already binary */
	     substr (unspec (RDW.length), 2, 9) = substr (unspec (RDW.length), 3, 8) || "0"b;
						/* shift high order byte to allow writing in 9 mode */
	RDW.pad = "0"b;				/* zero the pad field */
	cseg.offset = cseg.offset + 4;		/* the rdw has been processed */
	req_off = buf_len;				/* process buf_len characters */
	move = buf_len;				/* move buf_len characters */
	call move_to_buf;				/* move the data to the write buffer */
	if ^fd.blocked then call write_buf;		/* unblocked: write 1 record per block */
	else if fd.blklen - cseg.offset < 4 then call write_buf; /* write block if even null record can't fit */
	go to w_count;				/* return to caller */

w_format (4): if buf_len > fd.reclen then go to w_long;	/* VBS format - check buf_len validity */
	call get_buf;				/* get a buffer */
	peel = 0;					/* initialize character count */
	left = buf_len;				/* save request for decrementing */
	remain = fd.blklen - cseg.offset;		/* get number of characters left in block */
	dwP = addr (substr (buf, cseg.offset + 1));
w_fit_check:
	cseg.saveP = dwP;				/* save SDW location for pad incrementing */
	if left + 4 <= remain then do;		/* will entire request fit in remainder of block? */
		if left + 4 > remain - 5 then do;	/* Will request be last segment of block? */
			i = 4 - (remain - (left + 4));/* get nbr of chars in last word of block */
			if i = 0 then move = left;	/*  0 in last work: write all this segment */
			else if i = 4 then move = left; /* last word full: write all this segment */

/* this segment wont be word aligned; have to back track to previous segment
   and see how many characters have to be peeled off to make last segment of block word aligned */

			else do;
				peel = mod (cseg.offset, 4);
				if peel ^= 0 then do;
					hold = substr (buf, cseg.offset - peel + 1, peel); /* save the unaligned characters */
					if SDW.code = sdw.initial then ;
					else SDW.code = sdw.medial;
					SDW.length = SDW.length - peel; /* rewrite length - peeled chars in descriptor word */
					SDW.code = sdw.medial;
					substr (unspec (SDW.length), 2, 9) = substr (unspec (SDW.length), 3, 8) || "0"b;
					cseg.offset = cseg.offset - peel; /* update count to reflect peeled characters */
					total = total - peel; /* adjust for characters peeled also */
				     end;
				go to w_now;	/* segment is word aligned; write out buffer */
			     end;
		     end;
		else move = left;			/* not last segment of block - move all */
	     end;
	else move = remain - 4;			/* entire request won't fit - move what will */
	left = left - move;				/* decrement data to be moved count */
	if first_span then do;			/* first segment of the record */
		first_span = "0"b;			/* one time only */
		if left = 0 then SDW.code = sdw.complete; /* whole record in one segment */
		else SDW.code = sdw.initial;		/* only part of record fits */
	     end;
	else do;					/* not first segment of record */
		if left = 0 then SDW.code = sdw.final;	/* last segment of record */
		else SDW.code = sdw.medial;		/* still more to come */
	     end;
	data_len = move + peel + 4;			/* compute segment length */
	if peel > 0 then peel = 0;
	SDW.length = data_len;			/* store segment length */
	if fd.mode ^= binary then /* if not binary move right to binary from 9 mode */
	     substr (unspec (SDW.length), 2, 9) = substr (unspec (SDW.length), 3, 8) || "0"b;
	if cseg.standard = DOS then if data_len = 4 then substr (unspec (SDW.length), 2, 1) = "1"b;
	SDW.pad = "0"b;				/* zero pad field */
	cseg.offset = cseg.offset + 4;		/* SDW has been processed */
	req_off = move;				/* process the data move */
	call move_to_buf;				/* move data to write buffer */
	remain = remain - data_len;			/* get number of characters left after request */
	if ^fd.blocked then go to w_now;		/* ^blocked: write each segment */
	if remain < 5 then do;			/*  another segment can't fit in the block? */
w_now:		call write_buf;			/* write the block */
		call get_buf;			/* get another buffer */
		remain = fd.blklen - cseg.offset;	/* initialize number of remaining characters */
	     end;
	dwP = addr (substr (buf, cseg.offset + 1));	/* locate current SDW position */
	if peel ^= 0 then do;			/* pick up chars had to peel off */
		substr (buf, cseg.offset + 5, peel) = substr (hold, 1, peel); /* move chars into buffer */
		cseg.offset = cseg.offset + peel;
		total = total + peel;
		remain = fd.blklen - cseg.offset;
	     end;
	if left ^= 0 then go to w_fit_check;		/* if more segments need be written, continue processing */
	go to w_exit;				/* .... or return to caller */


w_long:	code = error_table_$long_record;		/* set return code */
	go to w_exit1;				/* csw can't be "1"b, shouldn't lock logical I/O */

w_count:	cseg.lrec.reccnt = cseg.lrec.reccnt + 1;

w_exit:	code = ecode;				/* set return code */
	cseg.code = code;
	if csw then go to c_exit;			/* if close entry, go to close exit */
w_exit1:	cseg.file_lock = "0"b;			/* unlock the file */
	return;					/* return to caller */

get_buf: procedure;					/* internal procedure to get a write buffer for data transfer */
	if cseg.lrec.bufP = null then do;		/* get a buffer if necessary */
		call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, 0); /* get the buffer */
		if fd.format > 2 then cseg.offset = 4;	/* set offset for BDW */
		else cseg.offset = 0;		/* initialize buffer offset */
	     end;
	return;					/* exit */
     end get_buf;


move_to_buf: procedure;				/* internal procedure to move data from user's buffer */
	if move = 0 then go to move_nothing;		/* return if no data to be moved */
	fromP = addr (substr (ub, total + 1));		/* set pointer to data to be moved */
	toP = addr (substr (buf, cseg.offset + 1));	/* set pointer to buffer */
	if fd.mode = ebcdic then call ascii_to_ebcdic_ (fromP -> data, toP -> data);
	else toP -> data = fromP -> data;		/* move as is */
	total = total + move;			/* sum each move */
move_nothing: cseg.offset = cseg.offset + req_off;	/* the request has been processed (char offset) */
	return;					/* return to caller */
     end move_to_buf;

write_buf: procedure;				/* internal procedure to write one physical block */
	if cseg.offset < 20 then if fd.format ^= 2 then do; /* pad to 20 bytes if not F format */
		     remain = 20 - cseg.offset;	/* get pad requirement */
		     go to w_pad;			/* pad the block */
		end;
	remain = 4 - mod (cseg.offset, 4);		/* block length must be integral multiple of 4 */
	if remain ^= 4 then do;			/* not multiple - pad to word boundry */
w_pad:		substr (buf, cseg.offset + 1, remain) = copy (rpad, remain); /* pad with blanks */
		cseg.offset = cseg.offset + remain;	/* increment to reflect padding */
	     end;
	else remain = 0;				/* multiple - indicate no padding performed */
	if fd.format > 2 then do;			/* should a BDW be included? */
		BDW.length = cseg.offset;		/* store the block length */
		if fd.mode ^= binary then
		     substr (unspec (BDW.length), 2, 9) = substr (unspec (BDW.length), 3, 8) || "0"b;
						/* shift high order byte to allow writing in 9 mode */
		BDW.pad = "0"b;			/* zero the pad field */
		if remain ^= 0 then do;		/* the block was padded: the last rdw must be incremented */
			dwP = cseg.saveP;		/* get the pointer to the last RDW used */
			if fd.mode ^= binary then
			     substr (unspec (RDW.length), 1, 10) = "00"b || substr (unspec (RDW.length), 2, 8); /* pack */
			if cseg.standard = DOS then substr (unspec (RDW.length), 3, 1) = "0"b; /* DOS 0 length seg bit */
			RDW.length = RDW.length + remain; /* increment to reflect added pad characters */
			if fd.mode ^= binary then
			     substr (unspec (RDW.length), 2, 9) = substr (unspec (RDW.length), 3, 8) || "0"b; /* unpack */
		     end;
	     end;
	call tape_ansi_tape_io_$write (cP, cseg.lrec.bufP, cseg.offset, ecode); /* write the block */
	if ecode = 0 then cseg.blkcnt = cseg.blkcnt + 1;	/* OK: up block count */
	else if ecode = error_table_$eov_on_write then do;/* EOT detected */
		cseg.blkcnt = cseg.blkcnt + 1;	/* block was written */
		if csw then return;			/* ignore EOT if closing */
		else do;
			if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eot (iocbP, ecode);
			else call tape_ansi_file_cntl_$data_eot (iocbP, ecode); /* switch to next volume */
			if ecode ^= 0 then do;	/* terminate if switching failed */
				if fd.format = 4 & left ^= 0 then go to w_exit; /* VS/VBS record only partially written */
				else do;		/* not VS/VBS format, or VS/VBS record completely written */
					cseg.code = ecode; /* inhibit further iox_$write_record calls */
					code = 0; /* but this call is ok */
					cseg.lrec.reccnt = cseg.lrec.reccnt + 1; /* so increment record count */
					go to w_exit1; /* and return to caller */
				     end;
			     end;
		     end;
	     end;
	else do;					/* IO error (occurred on previous block) */
		cseg.blkcnt = cseg.blkcnt - cseg.soft_status.nbuf + 1; /* decrement block count */
		cseg.lrec.reccnt = -cseg.lrec.reccnt;	/* make record count unreliable */
		go to w_exit;			/* terminate processing */
	     end;
	return;					/* return to caller */
     end write_buf;

close: entry (acP, code);				/* close entry to synchronize and terminate io */
	dcl     acP		 ptr;		/* pointer to control segment */

	cP = acP;					/* set pointer to control segment */
	csw = "1"b;				/* indicate close entry in case write error */
	if cseg.open_mode = 4 then do;		/* opened for input */
		if cseg.lrec.bufP ^= null then go to close2; /* release an active buffer */
		go to c_exit;			/* synchronize and finish up io */
	     end;
	else do;					/* file was opened for output */
		if cseg.lrec.bufP = null then go to c_exit; /* no active buffer - synchronize and close */
		if cseg.offset = 0 then go to close2;	/* active empty buffer - release, synch., and close */
		if fd.format > 2 then if cseg.offset = 4 then go to close2; /* active buffer has only a BDW */
		call write_buf;			/* active buffer with data - write the buffer */
		go to c_exit;			/* synchronize and close io */
	     end;
close2:	call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* release the buffer */
c_exit:	call tape_ansi_tape_io_$close (cP, code);	/* terminate the tape_ansi_tape_io_ set up */
	return;					/* exit */


     end tape_ansi_ibm_lrec_io_;




		    tape_ansi_interpret_status_.pl1 11/04/82  1931.3rew 11/04/82  1617.4       80676



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




tape_ansi_interpret_status_: procedure (hP);		/* interprets MTS500 hardware status bits */

/* hP points to a hardware status structure which contains the MTS500 status bits	*/
/* to be interpreted.  The error codes resulting from the interpretation of this string are	*/
/* returned in the structure.  Created May 3, 1974 by R.E. Klinger.				*/
/* Modified March 5, 1976 to add a new Command Reject substatus, Invalid Density		    */

dcl  hP pointer;					/* argument: pointer to hdw_status structure */

dcl 1 hdw_status based (hP),				/* hardware status structure */
    2 hard_stat bit (72) aligned,			/* tape status in bits 3-12 (from 1) (Input) */
    2 no_minor fixed bin,				/* number of minor status codes (Output) */
    2 major fixed bin (35),				/* major status code (Output) */
    2 minor (10) fixed bin (35);			/* minor status codes (Output) - 10 is arbitrary */

dcl  maj bit (4) unal based (addr (substr (hdw_status.hard_stat, 3))); /* major status portion of hardware status */

dcl  min bit (6) unal based (addr (substr (hdw_status.hard_stat, 7))); /* minor status portion of hardware status string */

/* automatic storage */
dcl (i, j) fixed bin;				/* temporary indices */

/* static storage */
dcl  init_req bit (1) internal static aligned init ("1"b);	/* initialization required bit */

dcl  major_bits (9) bit (4) internal static aligned init	/* major status bit possibilities */
    ("0101"b, "1101"b, "0100"b, "0011"b, "1011"b, "0010"b, "1010"b, "0001"b, "0000"b);

dcl  first_minor_index (9) fixed bin internal static init	/* lowest index into minor status mask and result arrays */
    (1, 8, 12, 16, 23, 35, 40, 50, 54);

dcl  last_minor_index (9) fixed bin internal static init	/* highest index into minor status mask and result arrays */
    (7, 11, 15, 22, 34, 39, 49, 53, 61);

dcl  mask (61) bit (6) internal static aligned init	/* minor status bit masks */
    ("111111"b,
     "111001"b,
     "111010"b,
     "111100"b,
    (10) (1) "111111"b,
     "000000"b,
     "111111"b,
     "111111"b,
     "000011"b,
     "000100"b,
     "001000"b,
     "010000"b,
     "100000"b,
    (12) (1) "111111"b,
     "110011"b,
     "111111"b,
     "100110"b,
     "101010"b,
     "110011"b,
    (15) (1) "111111"b,
     "001001"b,
     "111010"b,
     "000100"b,
     "110010"b,
     "110010"b,
     "110010"b,
     "111011"b);


dcl  result (61) bit (6) internal static aligned init	/* minor status match results */
    ("000000"b,
     "000001"b,
     "000010"b,
     "000100"b,
     "001000"b,
     "010000"b,
     "100000"b,
     "000001"b,
     "000010"b,
     "000011"b,
     "000100"b,
     "001111"b,
     "010011"b,
     "111111"b,
     "000000"b,
     "000001"b,
     "000010"b,
     "000011"b,
     "000100"b,
     "001000"b,
     "010000"b,
     "100000"b,
     "000001"b,
     "000010"b,
     "000011"b,
     "000100"b,
     "001000"b,
     "001001"b,
     "100000"b,
     "010000"b,
     "010001"b,
     "010010"b,
     "010011"b,
     "010100"b,
     "000001"b,
     "000010"b,
     "000100"b,
     "001000"b,
     "010000"b,
     "000001"b,
     "000010"b,
     "000011"b,
     "001000"b,
     "001100"b,
     "001101"b,
     "001110"b,
     "001111"b,
     "010000"b,
     "010001"b,
     "000001"b,
     "100000"b,
     "000010"b,
     "000100"b,
     "000000"b,
     "000001"b,
     "000010"b,
     "000100"b,
     "010000"b,
     "100000"b,
     "110000"b,
     "001000"b);


dcl  major_code (9) fixed bin (35) internal static;	/* major status codes */

dcl  minor_code (61) fixed bin (35) internal static;	/* minor status codes */

	
%include tape_status_codes;

dcl (addr, substr) builtin;


	
	if init_req then do;			/* initialize code arrays if necessary */
	     init_req = "0"b;
	     major_code (1) = tape_status_$command_reject;
	     major_code (2) = tape_status_$mpc_command_reject;
	     major_code (3) = tape_status_$end_of_file;
	     major_code (4) = tape_status_$device_data_alert;
	     major_code (5) = tape_status_$mpc_device_data_alert;
	     major_code (6) = tape_status_$device_attention;
	     major_code (7) = tape_status_$mpc_device_attention;
	     major_code (8) = tape_status_$device_busy;
	     major_code (9) = tape_status_$subsystem_ready;

	     minor_code (1) = tape_status_$invalid_density;
	     minor_code (2) = tape_status_$invalid_opcode;
	     minor_code (3) = tape_status_$invalid_device_code;
	     minor_code (4) = tape_status_$invalid_idcw_parity;
	     minor_code (5) = tape_status_$reject_at_bot;
	     minor_code (6) = tape_status_$read_after_write;
	     minor_code (7) = tape_status_$nine_track_error;
	     minor_code (8) = tape_status_$illegal_procedure;
	     minor_code (9) = tape_status_$illegal_lc_number;
	     minor_code (10) = tape_status_$illegal_susp_lc_number;
	     minor_code (11) = tape_status_$continue_not_set;
	     minor_code (12) = tape_status_$seven_track_eof;
	     minor_code (13) = tape_status_$nine_track_eof;
	     minor_code (14) = tape_status_$data_alert;
	     minor_code (15) = tape_status_$single_char_record;
	     minor_code (16) = tape_status_$transfer_timing;
	     minor_code (17) = tape_status_$blank_tape_on_read;
	     minor_code (18) = tape_status_$bit_during_erase;
	     minor_code (19) = tape_status_$transmission_parity;
	     minor_code (20) = tape_status_$lateral_parity;
	     minor_code (21) = tape_status_$longitudinal_parity;
	     minor_code (22) = tape_status_$end_of_tape;
	     minor_code (23) = tape_status_$transmission_alert;
	     minor_code (24) = tape_status_$inconsistent_command;
	     minor_code (25) = tape_status_$sum_check_error;
	     minor_code (26) = tape_status_$byte_locked_out;
	     minor_code (27) = tape_status_$pe_burst_error;
	     minor_code (28) = tape_status_$preamble_error;
	     minor_code (29) = tape_status_$marginal_condition;
	     minor_code (30) = tape_status_$multitrack_error;
	     minor_code (31) = tape_status_$skew_error;
	     minor_code (32) = tape_status_$postamble_error;
	     minor_code (33) = tape_status_$nrzi_ccc_error;
	     minor_code (34) = tape_status_$code_alert;
	     minor_code (35) = tape_status_$write_protect_attention;
	     minor_code (36) = tape_status_$no_such_device;
	     minor_code (37) = tape_status_$device_in_standby;
	     minor_code (38) = tape_status_$device_check;
	     minor_code (39) = tape_status_$blank_tape_on_write;
	     minor_code (40) = tape_status_$configuration_error;
	     minor_code (41) = tape_status_$multiple_devices;
	     minor_code (42) = tape_status_$illegal_device_id;
	     minor_code (43) = tape_status_$incompatible_mode;
	     minor_code (44) = tape_status_$tca_malfunction_port0;
	     minor_code (45) = tape_status_$tca_malfunction_port1;
	     minor_code (46) = tape_status_$tca_malfunction_port2;
	     minor_code (47) = tape_status_$tca_malfunction_port3;
	     minor_code (48) = tape_status_$mth_malfunction;
	     minor_code (49) = tape_status_$multiple_bot;
	     minor_code (50) = tape_status_$in_rewind;
	     minor_code (51) = tape_status_$device_reserved;
	     minor_code (52) = tape_status_$alternate_channel;
	     minor_code (53) = tape_status_$device_loading;
	     minor_code (54) = tape_status_$device_ready;
	     minor_code (55) = tape_status_$write_protected;
	     minor_code (56) = tape_status_$ready_at_bot;
	     minor_code (57) = tape_status_$nine_track_handler;
	     minor_code (58) = tape_status_$two_bit_fill;
	     minor_code (59) = tape_status_$four_bit_fill;
	     minor_code (60) = tape_status_$six_bit_fill;
	     minor_code (61) = tape_status_$ascii_alert;
	end;



	do i = 1 to 9;				/* look for the major status bits */
	     if maj = major_bits (i) then go to found;
	end;

found:	hdw_status.major = major_code (i);		/* set the major status code */
	hdw_status.no_minor = 0;			/* initialize the minor status count */
	do j = first_minor_index (i) to last_minor_index (i); /* look for minor status bits */
	     if (min & mask (j)) = result (j) then do;	/* test */
		hdw_status.no_minor = hdw_status.no_minor + 1; /* increment the minor status count */
		hdw_status.minor (hdw_status.no_minor) = minor_code (j); /* set the minor status code */
	     end;
	end;

	if i = 3 then hdw_status.no_minor = 1;		/* EOF major status - drop multiple SCR code */

	return;

     end tape_ansi_interpret_status_;




		    tape_ansi_lrec_io_.pl1          11/04/82  1931.3rew 11/04/82  1606.0      214452



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


/* Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes */

tape_ansi_lrec_io_: procedure;
						/* argument list */
	dcl     iocbP		 ptr,		/* pointer to IO control block */
	        ubP		 ptr,		/* pointer to user buffer */
	        buf_len		 fixed bin (21),	/* number of characters requested for IO */
	        rec_len		 fixed bin (21),	/* number of characters read */
	        code		 fixed bin (35);	/* error code */

%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;

%include tape_ansi_fl;


/* based overlays */
	dcl     buf		 char (cseg.buf_size) aligned based (cseg.lrec.bufP), /* one physical block */
	        data		 char (move) unaligned based, /* overlay for data move */
	        RCW		 char (4) unaligned based (dwP); /* D-format rdw */
	dcl     1 SCW		 based (dwP),	/* segment control word */
		2 code		 char (1) unaligned,/* control code */
		2 length		 char (4) unaligned;/* length of segment */
	dcl     ub		 char (buf_len) unaligned based (ubP); /* user buffer overlay */

/* error codes */
	dcl     (error_table_$eov_on_write,
	        error_table_$file_busy,
	        error_table_$invalid_record_desc,
	        error_table_$long_record,
	        error_table_$tape_error,
	        error_table_$fatal_error,
	        error_table_$eof_record) fixed bin (35) external static;


/* builtin functions */
	dcl     (addr, binary, decimal, mod, null, substr, verify) builtin;

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

/* automatic storage */
	dcl     (i, j)		 fixed bin,	/* temporary storage */
	        csw		 bit (1) init ("0"b), /* indicates close entry */
	        total		 fixed bin (21) initial (0), /* number of characters moved in this request */
	        move		 fixed bin initial (0), /* number of characters moved per segment/record */
	        left		 fixed bin (21),	/* number of characters remaining for this request */
	        long_record		 bit (1) initial ("0"b), /* long record switch */
	        parity_error	 bit (1) initial ("0"b), /* parity error switch */
	        req_off		 fixed bin,	/* number of buffer characters processed by this request */
	        remain		 fixed bin,	/* number of unprocessed characters in buffer */
	        ecode		 fixed bin (35) init (0), /* temporary error code */
	        data_len		 fixed bin initial (0), /* number of characters in varying length record */
	        cwl		 picture "9999",	/* control word length for RCW and SCW */
	        first_span		 bit (1) initial ("1"b); /* first segment of spanned request switch */

/* pointers */
	dcl     dwP		 ptr,		/* pointer to RCW - SCW */
	        fromP		 ptr,		/* pointer to buffer for data move */
	        toP		 ptr;		/* pointer to user buffer for data move */

/* static storage */
	dcl     1 scw		 internal static aligned, /* SCW data */
		2 complete	 char (1) initial ("0"), /* complete code - ASCII 0 */
		2 initial		 char (1) initial ("1"), /* initial code - ASCII 1 */
		2 medial		 char (1) initial ("2"), /* medial code - ASCII 2 */
		2 final		 char (1) initial ("3"); /* final code - ASCII 3 */

	dcl     bpad		 char (20) internal static init ((20)"^");

	dcl     ebcdic		 init (2) fixed bin internal static;

/* subroutine calls */
	dcl     ascii_to_ebcdic_	 ext entry (char (*), char (*)),
	        ebcdic_to_ascii_	 ext entry (char (*), char (*)),
	        tape_ansi_file_cntl_$data_eof ext entry (ptr, fixed bin (35)),
	        tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35)),
	        tape_ansi_file_cntl_$position_for_output ext entry (ptr, fixed bin (35)),
	        tape_ansi_tape_io_$close ext entry (ptr, fixed bin (35)),
	        tape_ansi_tape_io_$get_buffer ext entry (ptr, ptr, fixed bin (35)),
	        tape_ansi_tape_io_$read ext entry (ptr, ptr, fixed bin, fixed bin (35)),
	        tape_ansi_tape_io_$release_buffer ext entry (ptr, ptr, fixed bin (35)),
	        tape_ansi_tape_io_$write ext entry (ptr, ptr, fixed bin, fixed bin (35));

read_record: entry (iocbP, ubP, buf_len, rec_len, code);	/* read_record entry point */

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */

	if cseg.file_lock then do;
		rec_len = 0;
		code = error_table_$file_busy;
		return;
	     end;
	else do;
		on cleanup begin;
			cseg.file_lock = "0"b;
			cseg.code = error_table_$fatal_error;
		     end;
		cseg.file_lock = "1"b;
	     end;

	if cseg.code ^= 0 then do;			/* was there a non-restartable error? */
		code = cseg.code;			/* set return code */
		cseg.file_lock = "0"b;
		return;
	     end;

	if cseg.rlN ^= -1 then do;			/* data record is in read length segment */
		if buf_len >= cseg.rlN then do;	/* user wants as much as (or more than) we have */
			code = 0;
			move = cseg.rlN;		/* give only as much as we have */
		     end;
		else do;				/* user wants less than we have */
			code = error_table_$long_record;
			move = buf_len;		/* give what s(he) wants */
		     end;
		ubP -> data = cseg.rlP -> data;	/* move to user */
		rec_len = move;			/* indicate amount moved */
		cseg.rlN = -1;			/* read length buffer is now empty */
		cseg.lrec.reccnt = cseg.lrec.reccnt + 1;
		cseg.file_lock = "0"b;
		return;
	     end;

	go to r_format (fd.format);			/* transfer to begin processing */

r_format (1): call get_record;			/* U format - get a logical record */
	move = remain;				/* user gets all, even pad chars (if any) */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move as much as can fit */
	     end;
	req_off = remain;				/* this request processes the entire block */
	call move_to_user;				/* move data to user's workspace */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (2): call get_record;			/* get 1 record */
	if fd.reclen > remain then move = remain;	/* don't try to move more than we have */
	else move = fd.reclen;			/* move only up to 1 record's worth */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move only what can fit */
	     end;
	req_off = fd.reclen;			/* process one record */
	call move_to_user;				/* move data to user's workspace */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (3): call get_record;			/* D format - get a logical record */
	if substr (buf, cseg.offset + 1, 1) = "^" then do;/* pad RCW? */
		call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* pad rcw is last in block */
		go to r_format (3);			/* try again */
	     end;
	dwP = addr (substr (buf, cseg.offset + 1));	/* get pointer to rcw */
	on conversion go to inv_desc;			/* detect invalid descriptor */
	data_len = binary (RCW, 17) - 4;		/* get length of data */
	revert conversion;				/* stop handling the condition */
	if data_len > remain - 4 then go to inv_desc;	/* block bigger than block size? */
	move = data_len;				/* move up to 1 record */
	if buf_len < move then do;			/* buffer < record */
		long_record = "1"b;
		move = buf_len;			/* move only what can fit */
	     end;
	cseg.offset = cseg.offset + 4;		/* the rdw has been processed */
	req_off = data_len;				/* process one logical record */
	call move_to_user;				/* move data to user's workspace */
	call read_release;				/* release the record */
	go to r_count;				/* return to caller */

r_format (4): call get_record;			/* S format - get a logical record */
	left = buf_len;				/* save request for decrementing */
r_sw_check: call process_sw;				/* process the SCW - get type and data length */
	if left >= data_len then move = data_len;	/* give user the entire segment..... */
	else do;					/* user doesn't want all the data */
		long_record = "1"b;			/* buffer < record */
		move = left;			/* move only as much as can fit */
	     end;
	call move_to_user;				/* move the data to the user's workspace */
	left = left - move;				/* keep track of remainder of request */
	if SCW.code = scw.complete | SCW.code = scw.final then do; /* segment is last (or only) of record */
		call read_release;			/* release it */
		go to r_count;			/* and we're done */
	     end;
	else call read_release;			/* release the record and continue */
	if left ^= 0 then do;			/* user wants more, and more segments are available */
		call get_record;			/* get the next segment */
		go to r_sw_check;			/* transfer to process the SCW/SDW, etc. ..... */
	     end;
	call skip_segments;				/* request satisfied, but more segments remain - skip them */
	long_record = "1"b;				/* buffer < record */
	go to r_count;				/* return to caller */

inv_desc: ecode = error_table_$invalid_record_desc;	/* set error ecode */
	go to r_exit;

r_count:	cseg.lrec.reccnt = cseg.lrec.reccnt + 1;

r_exit:	if parity_error then code = error_table_$tape_error;
	else code = ecode;
	cseg.code = code;
	if code = 0 then if long_record then code = error_table_$long_record;
	rec_len = total;				/* return total number of characters moved */
	cseg.file_lock = "0"b;
	return;					/* and return to the caller */

get_record: procedure;				/* internal procedure to get 1 logical record */
	if cseg.lrec.bufP = null then do;		/* get a block if inactive buffer */
restart:		call tape_ansi_tape_io_$read (cP, cseg.lrec.bufP, cseg.nc_buf, ecode); /* get 1 physical block */
		if ecode ^= 0 then do;		/* was there an error or EOF? */
			if ecode = error_table_$eof_record then do; /* EOF detected */
				call tape_ansi_file_cntl_$data_eof (iocbP, ecode); /* see if follow-on volume */
				if ecode = 0 then go to restart; /* switched to new file section */
				else go to r_exit;	/* no next volume or error */
			     end;
			else do;			/* not EOF - some sort of error */
				if ecode = error_table_$tape_error then parity_error = "1"b; /* process this block */
				else go to r_exit;	/* terminate processing */
			     end;
		     end;
		cseg.blkcnt = cseg.blkcnt + 1;	/* keep track of physical blocks read */
		cseg.offset = fd.bo;		/* skip ANSI block prefix, if any */
		if cseg.nc_buf - cseg.offset < 0 then do; /* fatal error */
			ecode = error_table_$fatal_error;
			go to r_exit;
		     end;
		if cseg.nc_buf > fd.blklen then cseg.nc_buf = fd.blklen; /* eliminate obvious padding */
		if fd.format = 2 then do;		/* F/FB - strip pad characters */
			i = (cseg.nc_buf - fd.bo) / fd.reclen; /* # of records */
			j = mod (cseg.nc_buf - fd.bo, fd.reclen); /* # of extra chars */
			if j ^= 0 then do;		/* if any, test them */
				if verify (substr (buf, cseg.nc_buf - j + 1, j), "^") = 0
				then cseg.nc_buf = cseg.nc_buf - j; /* all pad - eliminate */
				else go to out;	/* keep all - treat as short record */
			     end;
			do j = i to 1 by -1;	/* test records for all "^" */
			     if verify (substr (buf, fd.bo + ((j - 1) * fd.reclen) + 1, fd.reclen), "^") = 0
			     then cseg.nc_buf = cseg.nc_buf - fd.reclen;
			     else go to out;	/* reached end of pad characters */
			end;
		     end;
	     end;
out:	remain = cseg.nc_buf - cseg.offset;		/* get number of characters to be processed */
	return;					/* exit */
     end get_record;

process_sw: procedure;				/* internal procedure to process SCW's */
ck_dw:	if substr (buf, cseg.offset + 1, 1) = "^" then do;/* pad SCW? */
		call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* all pad chars - release block */
		call get_record;			/* get another record */
		go to ck_dw;			/* try again */
	     end;
	dwP = addr (substr (buf, cseg.offset + 1));	/* get pointer to SDW/SCW */
	on conversion go to inv_desc;			/* handle the conversion condition */
	data_len = binary (SCW.length, 17) - 5;		/* get length of data */
	if binary (SCW.code) > 3 then go to inv_desc;	/* error if SCW.code > 3 */
	if data_len > remain - 5 then go to inv_desc;	/* block greater than block size? */
	revert conversion;				/* disable the condition handler */
	cseg.offset = cseg.offset + 5;		/* SCW has been processed */
	req_off = data_len;				/* the entire segment will be processed */
	return;					/* exit */
     end process_sw;

skip_segments: procedure;				/* internal procedure to skip to beginning of spanned record */
s_get:	call get_record;				/* get a segment */
	call process_sw;				/* process its SCW/SDW */
	if SCW.code = scw.final then do;		/* is this the final segment? */
		call read_release;			/* release it */
		return;				/* and exit */
	     end;
	call read_release;				/* release the segment */
	go to s_get;				/* get the next segment */
     end skip_segments;

move_to_user: procedure;				/* internal procedure to move data to user's workspace */

	if move = 0 then return;
	fromP = addr (substr (buf, cseg.offset + 1));	/* set pointer to data to be moved */
	toP = addr (substr (ub, total + 1));		/* set pointer to user buffer */
	if fd.mode ^= ebcdic then toP -> data = fromP -> data; /* ascii/binary */
	else call ebcdic_to_ascii_ (fromP -> data, toP -> data); /* ebcdic */
	total = total + move;			/* sum each move */
	return;					/* exit */
     end move_to_user;

read_release: procedure;				/* internal procedure to release a record and/or block */
	cseg.offset = cseg.offset + req_off;		/* the request has been processed */
	remain = cseg.nc_buf - cseg.offset;		/* get number of characters not yet processed */
	if fd.format = 4 then if remain < 5 then go to release_it; /* S format and SCW can't fit */
	     else return;				/* S format and SCW can fit */
	if remain < 4 then do;			/* if so, the block may have been exhausted */
		if fd.format = 2 then if fd.reclen <= remain then return;
						/* save if another record could fit */
release_it:	call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* block exhausted */
	     end;
	return;					/* exit */
     end read_release;

write_record: entry (iocbP, ubP, buf_len, code);		/* write_record entry point */

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */

	if cseg.file_lock then do;
		code = error_table_$file_busy;
		return;
	     end;
	else do;
		on cleanup begin;
			cseg.file_lock = "0"b;
			cseg.code = error_table_$fatal_error;
		     end;
		cseg.file_lock = "1"b;
	     end;

	if cseg.code ^= 0 then do;			/* was there a non-restartable error? */
		code = cseg.code;			/* set return code */
		cseg.file_lock = "0"b;
		return;
	     end;

	if vl (fl.vlX).pos ^= 1 then do;		/* not positioned for output */
		call tape_ansi_file_cntl_$position_for_output (iocbP, ecode);
		if ecode ^= 0 then go to w_exit;	/* error */
	     end;

	go to w_format (fd.format);			/* transfer to begin processing */



w_format (1): if buf_len > fd.blklen - fd.bo then go to w_long; /* U format - check buf_len */
	call get_buf;				/* get a buffer */
	move = buf_len;				/* move the requested amount of data */
	req_off = buf_len;				/* number of characters to be processed */
	call move_to_buf;				/* move the data to the write buffer */
	call write_buf;				/* write one block */
	go to w_count;				/* return to caller */

w_format (2): if buf_len > fd.reclen then go to w_long;	/* F format - check buf_len validity */
	call get_buf;				/* get a buffer */
	move = buf_len;				/* transfer the request as stated */
	remain = fd.reclen - buf_len;			/* get difference between buf_len and reclen for padding */
	if remain ^= 0 then substr (buf, cseg.offset + buf_len + 1, remain) = " "; /* pad the record */
	req_off = fd.reclen;			/* process one logical record */
	call move_to_buf;				/* move the data to the write buffer */
	if ^fd.blocked then call write_buf;		/* unblocked: write 1 record per block */
	else if cseg.offset = fd.blklen then call write_buf; /* blocked: write if block full */
	go to w_count;				/* return to caller */

w_format (3): data_len = buf_len + 4;			/* D format - record length = buf_len + rdw length */
	if data_len > fd.reclen then go to w_long;	/* check data_len validity */
	call get_buf;				/* get a buffer */
	if fd.blocked then if data_len > fd.blklen - cseg.offset then do; /* record won't fit in this block */
		     call write_buf;		/* write the current buffer contents */
		     call get_buf;			/* get another write buffer */
		end;				/* request validity has been verified, so just continue */
	dwP = addr (substr (buf, cseg.offset + 1));	/* locate rdw position */
	cwl = decimal (data_len, 4);			/* convert length to ASCII characters */
	RCW = cwl;				/* store in RCW */
	cseg.offset = cseg.offset + 4;		/* the rdw has been processed */
	req_off = buf_len;				/* process buf_len characters */
	move = buf_len;				/* move buf_len characters */
	call move_to_buf;				/* move the data to the write buffer */
	if ^fd.blocked then call write_buf;		/* unblocked: write 1 record per block */
	else if fd.blklen - cseg.offset < 4 then call write_buf; /* write block if even null record can't fit */
	go to w_count;				/* return to caller */

w_format (4): if buf_len > fd.reclen then go to w_long;	/* S format - check buf_len validity */
	call get_buf;				/* get a buffer */
	left = buf_len;				/* save request for decrementing */
	remain = fd.blklen - cseg.offset;		/* get number of characters left in block */
w_fit_check: dwP = addr (substr (buf, cseg.offset + 1));	/* locate SCW position */
	if left + 5 <= remain then do;		/* will the request fit entirely? */
		if first_span then SCW.code = scw.complete; /* if first segment then code is complete */
		else SCW.code = scw.final;		/* else code is final */
		move = left;			/* move all the data */
	     end;
	else do;					/* request will not fit in block */
		if first_span then do;		/* if first segment then this is initial */
			SCW.code = scw.initial;	/* set code */
			first_span = "0"b;		/* set switch to indicate medial/final segments to follow */
		     end;
		else SCW.code = scw.medial;		/* not first segment, won't fit -- medial segment */
		move = remain - 5;			/* move as much data as will fit */
	     end;
	left = left - move;				/* decrement data to be moved count */
	data_len = move + 5;			/* compute segment length */
	cwl = decimal (data_len, 4);			/* convert length to ASCII characters */
	SCW.length = cwl;				/* store in SCW */
	cseg.offset = cseg.offset + 5;		/* SCW has been processed */
	req_off = move;				/* process the data move */
	call move_to_buf;				/* move data to write buffer */
	remain = remain - data_len;			/* get number of characters left after request */
	if ^fd.blocked then go to w_now;		/* write each segment if not blocked */
	if remain < 6 then do;			/*  blocked: could another segment fit? */
w_now:		call write_buf;			/* write the block */
		call get_buf;			/* get another buffer */
		remain = fd.blklen - cseg.offset;	/* initialize number of remaining characters */
	     end;
	if left ^= 0 then go to w_fit_check;		/* if more segments need be written, continue processing */
	go to w_count;				/* .... or return to caller */


w_long:	code = error_table_$long_record;		/* set return code */
	go to w_exit1;				/* csw can't be "1"b and shouldn't lock file */

w_count:	cseg.lrec.reccnt = cseg.lrec.reccnt + 1;	/* increment record count */

w_exit:	code = ecode;				/* return error code (if any) */
	cseg.code = code;				/* set logical record I/O lock (if any) */
	if csw then go to c_exit;			/* if close entry, go to close exit */
w_exit1:	cseg.file_lock = "0"b;			/* unlock the file */
	return;					/* return to caller */

get_buf: procedure;					/* internal procedure to get a write buffer for data transfer */
	if cseg.lrec.bufP = null then do;		/* get a buffer if necessary */
		call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, 0); /* get the buffer */
		cseg.offset = fd.bo;		/* initialize buffer offset */
		if cseg.offset ^= 0 then substr (buf, 1, cseg.offset) = ""; /* set to blanks */
	     end;
	return;					/* exit */
     end get_buf;


move_to_buf: procedure;				/* internal procedure to move data from user's buffer */
	if move = 0 then go to move_nothing;		/* return if no data to be moved */
	fromP = addr (substr (ub, total + 1));		/* set pointer to data to be moved */
	toP = addr (substr (buf, cseg.offset + 1));	/* set pointer to buffer */
	if fd.mode ^= ebcdic then toP -> data = fromP -> data; /* ascii/binary */
	else call ascii_to_ebcdic_ (fromP -> data, toP -> data); /* ebcdic */
	total = total + move;			/* sum each move */
move_nothing: cseg.offset = cseg.offset + req_off;	/* the request has been processed */
	return;					/* return to caller */
     end move_to_buf;

write_buf: procedure;				/* internal procedure to write one physical block */
	if cseg.offset < 20 then do;			/* pad to 20 bytes if < 20 bytes */
		remain = 20 - cseg.offset;		/* get pad requirement */
		go to w_pad;			/* pad the block */
	     end;
w_mod:	remain = 4 - mod (cseg.offset, 4);		/* get difference between actual and desired blklen */
	if remain = 4 then go to w_put;		/* length is correct - do not pad */
w_pad:	substr (buf, cseg.offset + 1, remain) = substr (bpad, 1, remain); /* pad with circumflex */
	cseg.offset = cseg.offset + remain;		/* increment to reflect padding */
w_put:	call tape_ansi_tape_io_$write (cP, cseg.lrec.bufP, cseg.offset, ecode); /* write the block */
	if ecode = 0 then cseg.blkcnt = cseg.blkcnt + 1;	/* OK: up block count */
	else if ecode = error_table_$eov_on_write then do;/* EOT detected */
		cseg.blkcnt = cseg.blkcnt + 1;	/* block was written */
		if csw then return;			/* ignore EOT if closing */
		else do;
			call tape_ansi_file_cntl_$data_eot (iocbP, ecode); /* switch to next volume */
			if ecode ^= 0 then do;	/* terminate if switching failed */
				if fd.format = 4 & left ^= 0 then go to w_exit; /* S format record only partially written */
				else do;		/* not S format, or S and completely written */
					cseg.code = ecode; /* inhibit further iox_$write_record calls */
					code = 0; /* but return no error on this call */
					cseg.lrec.reccnt = cseg.lrec.reccnt + 1; /* increment record count */
					go to w_exit1; /* return to caller */
				     end;
			     end;
		     end;
	     end;
	else do;					/* IO error (occurred on a previous block) */
		cseg.blkcnt = cseg.blkcnt - cseg.soft_status.nbuf + 1; /* decrement block count */
		cseg.lrec.reccnt = -cseg.lrec.reccnt;	/* make record count unreliable */
		go to w_exit;			/* terminate processing */
	     end;
	return;					/* return to caller */
     end write_buf;

close: entry (acP, code);				/* close entry to synchronize and terminate io */
	dcl     acP		 ptr;		/* pointer to control segment */

	cP = acP;					/* set pointer to control segment */
	csw = "1"b;				/* indicate close entry in case write error */
	if cseg.open_mode = 4 then do;		/* opened for input */
		if cseg.lrec.bufP ^= null then go to close2; /* release an active buffer */
		go to c_exit;			/* synchronize and finish up io */
	     end;
	else do;					/* file was opened for output */
		if cseg.lrec.bufP = null then go to c_exit; /* no active buffer - synchronize and close */
		if cseg.offset = 0 then go to close2;	/* active empty buffer - release, synch., and close */
		if cseg.offset = fd.bo then go to close2; /* buffer has only a block prefix */
		call write_buf;			/* active buffer with data - write the buffer */
		go to c_exit;			/* synchronize and close io */
	     end;
close2:	call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* release the buffer */
c_exit:	call tape_ansi_tape_io_$close (cP, code);	/* terminate the tape_ansi_tape_io_ set up */
	return;					/* exit */

     end tape_ansi_lrec_io_;




		    tape_ansi_mount_cntl_.pl1       12/17/86  0926.4r w 12/17/86  0829.4      200538



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


/****^  HISTORY COMMENTS:
  1) change(86-08-18,GWMay), approve(), audit(), install():
     old history comments:
     0) Created:  09/25/74 by Ross E. Klinger
     1) Modified: 11/06/74 by Ross E. Klinger
     2) Modified: 10/26/76 by Janice B. Phillipps
     3) Modified: 04/05/77 by Janice B. Phillipps
     4) Modified: 04/11/78 by C. D. Tavares
     5) Modified: 04/28/78 by Michael R. Jordan
     6) Modified: 4/79     by R.J.C. Kissel
     7) Modified: 4/82     by J. A. Bush for block sizes > 8192 bytes
     8) Modified: 9/83     by J. A. Bush to compile with modified include
                                files, (ansi ibm)_vol1.incl.pl1
  2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-17,Dupuis),
     install(86-09-24,MR12.0-1162):
     Changed the use of the cseg.wait_switch array.  Rather than assigning the
     6th and 7th chars of the tape device name as an index into the array, the
     index will be set to the index of the cseg.vl array which is a one to one
     correspondence.
                                                   END HISTORY COMMENTS */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*                                                                       */
/*  N__a_m_e:  tape_ansi_mount_cntl_                                                */
/*                                                                       */
/*       This module performs the following functions:                   */
/*  1)  mount - assigns drive and mounts volume;                         */
/*  2)  remount - demounts volume, mounts new volume on assigned drive;  */
/*  3)  free - unassigns a drive, demounting volume (if any);            */
/*  4)  insert_rings - inserts write rings in every mounted volume;      */
/*  5)  write_protect - sets every active drive to inhibit writing;      */
/*  6)  write_permit - sets every active drive w/ring to permit writing  */
/*                                                                       */
/*  U__s_a_g_e                                                                */
/*                                                                       */
/* dcl tape_ansi_mount_cntl_$mount ext entry                             */
/*                           (ptr, fixed bin, fixed bin (35)),           */
/*     tape_ansi_mount_cntl_$remount ext entry                           */
/*                           (ptr, ptr, fixed bin, fixed bin (35)),      */
/*     tape_ansi_mount_cntl_$free ext entry                              */
/*                           (ptr, fixed bin, fixed bin (35)),           */
/*     tape_ansi_mount_cntl_$insert_rings ext entry                      */
/*                           (ptr, fixed bin (35)),                      */
/*     tape_ansi_mount_cntl_$write_protect ext entry                     */
/*                           (ptr, fixed bin (35)),                      */
/*     tape_ansi_mount_cntl_$write_permit ext entry                      */
/*                           (ptr, fixed bin (35));                      */
/*                                                                       */
/*       call tape_ansi_mount_cntl_$mount (cP, vlX, code);               */
/*       call tape_ansi_mount_cntl_$remount (cP, down_vlX, vlX, code);   */
/*       call tape_ansi_mount_cntl_$free (cP, vlX, code);                */
/*       call tape_ansi_mount_cntl_$insert_rings (cP, code);             */
/*       call tape_ansi_mount_cntl_$write_protect (cP, code);            */
/*       call tape_ansi_mount_cntl_$write_permit (cP, code);             */
/*                                                                       */
/*  1) cP        is a pointer to tape_ansi_cseg.  (Input)                */
/*                                                                       */
/*  2) vlX       is the index of the volume link array element of the    */
/*               volume to be mounted or freed.  (Input)                 */
/*                                                                       */
/*  3) down_vlX  is the index of the volume link of the volume to be     */
/*               dismounted.  (Input)                                    */
/*                                                                       */
/*  4) code      is a standard Multics status code.  (Output)            */
/*                                                                       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tape_ansi_mount_cntl_:
     procedure;

/* parameters */
dcl      vlX		  fixed bin,
         down_vlX		  fixed bin,
         code		  fixed bin (35);

%include tape_ansi_cseg;

%include ibm_vol1;

%include ansi_vol1;

%include rcp_volume_formats;

%include rcp_resource_types;


/* automatic storage */

dcl      can_retry		  bit (1) init ("1"b),
         den		  fixed bin,		/* density code for tape_ansi_tape_io_$order */
         drive_name		  char (32),		/* drive name for user mount message */
         i		  fixed bin,		/* label length */
         op		  char (3),		/* operation for protect/permit entries */
         part		  char (2) varying,		/* particle for user mount message */
         vX		  fixed bin;		/* index of current volume link */

/* based storage */
dcl      VOL1_label_id	  char (4) based (addr (cseg.lbl_buf));
						/* label identifier of VOL1 label (ANSI or IBM) */

dcl      VOL1_80th_char	  char (1) based (addr (substr (cseg.lbl_buf, 80)));
						/* 80th character of VOL1 label */

/* conditions */
dcl      cleanup		  condition;

/* builtin functions */
dcl      (addr, before, binary, divide, rtrim, substr)
			  builtin;

/* external procedures */
dcl      authenticate_	  ext entry (char (*)) returns (char (3) aligned),
         cv_dec_check_	  ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
         canon_for_volume_label_
			  entry (char (*), char (*), char (*), fixed bin, fixed bin (35)),
         ebcdic_to_ascii_	  ext entry (char (*), char (*)),
         ioa_		  ext entry options (variable),
         ipc_$block		  ext entry (ptr, ptr, fixed bin (35)),
         ipc_$create_ev_chn	  ext entry (fixed bin (71), fixed bin (35)),
         ipc_$delete_ev_chn	  ext entry (fixed bin (71), fixed bin (35)),
         tape_ansi_tape_io_$order
			  ext entry (ptr, char (3), fixed bin, fixed bin (35)),
         tape_ansi_tape_io_$sync_read
			  ext entry (ptr, fixed bin, fixed bin (35)),
         tdcm_$tdcm_attach	  ext entry (ptr, fixed bin (35)),
         tdcm_$tdcm_set_buf_size
			  ext entry (ptr, fixed bin, fixed bin (35)),
         tdcm_$tdcm_detach	  ext entry (ptr, fixed bin (35)),
         tdcm_$tdcm_iocall	  ext entry (ptr, fixed bin (35)),
         tdcm_$tdcm_message	  ext entry (ptr, char (*), fixed bin, fixed bin (35)),
         tdcm_$tdcm_reset_signal
			  ext entry (ptr, fixed bin (35)),
         tdcm_$tdcm_set_signal  ext entry (ptr, fixed bin (35));

/* external static */
dcl      (
         error_table_$bad_mount_request,
         error_table_$eof_record,
         error_table_$blank_tape
         )		  ext static fixed bin (35);

mount:
     entry (cP, vlX, code);				/* assign a drive and mount a volume */

	vX = vlX;					/* set index of current volume link */

	on cleanup call cleaner;			/* don't leave event channels or drives */

	call ipc_$create_ev_chn (tseg.ev_chan, code);	/* get an event channel */
	if code ^= 0 then
	     return;

	tseg.version_num = cseg_tseg_version_2;
	tseg.tracks = 0;				/* nine-track drive */

	tseg.speed = cseg.speed;

	if cseg.density = -1 then do;
	     if cseg.standard = 1 then
		tseg.density = "00100"b;		/* 800 bpi */
	     else tseg.density = "00010"b;		/* 1600 bpi */
	end;

	else do;
	     if cseg.density = 2 then
		tseg.density = "00100"b;		/* 800 bpi */
	     else if cseg.density = 3 then
		tseg.density = "00010"b;		/* 1600 bpi */
	     else if cseg.density = 4 then
		tseg.density = "00001"b;		/* 6250 bpi */
	     else tseg.density = "00100"b;		/* 800 bpi */
	end;

	tseg.buffer_count = 0;			/* attach call */
	tseg.get_size = 1;				/* all IO to return block lengths */
	call tdcm_$tdcm_attach (addr (tseg), code);	/* assign a drive */
	if code ^= 0 then
	     go to er_exit;				/* trouble */
	else cseg.nactive = cseg.nactive + 1;		/* ok - up active count */
	if cseg.buf_size > 8192 then do;		/* if user requesting large block size... */
	     call tdcm_$tdcm_set_buf_size (addr (tseg), divide (cseg.buf_size, 4, 17, 0), code);
	     if code ^= 0 then			/* if could'nt assign it.. */
		go to er_exit;
	end;

up:
	call mount_request;				/* issue message to operator and wait */

	vl (vX).rcp_id = vX;                              /* fill volume link */

	vl (vX).tape_drive = tseg.drive_name;
	vl (vX).event_chan = tseg.ev_chan;
	vl (vX).ws_segno = tseg.ws_segno;		/* save IOI wks segno */
	vl (vX).cflX = 0;

	call VOL1_check (code);			/* verify status of VOL1 label */
	if code ^= 0 then
	     go to er_exit;				/* trouble */

/* only if VOL label looks good do we check the file labels for valid standard */
/*
   if vl (vX).write_VOL1 = 0 then call hdr_eox_check (code);
*/
	if code ^= 0 then do;
	     vl (vX).write_VOL1 = 6;			/* not standard file set */
	     code = 0;
	end;

	return;

remount:
     entry (cP, down_vlX, vlX, code);			/* switches volumes on an active drive */

	vX = down_vlX;				/* first work with down volume */

	tseg.drive_name = vl (vX).tape_drive;		/* set tseg to use this drive */
	tseg.ev_chan = vl (vX).event_chan;
	tseg.ws_segno = vl (vX).ws_segno;

	on cleanup call cleaner;			/* exit with consistency */

	vl (vX).cflX = 0;				/* invalidate position */
	call unload;

	vl (vX).rcp_id = 0;				/* invalidate volume link */

	vX = vlX;					/* now work with volume to go up */

	go to up;					/* mount the new volume */

insert_rings:
     entry (cP, code);				/* dismount, insert rings, and remount */

	on cleanup call cleaner;			/* don't leave event channel or drive */
	cseg.write_ring = "1"b;			/* rings will be in */
	do vX = 1 to cseg.vcN;			/* test each volume */
	     if vl (vX).rcp_id ^= 0 then do;		/* mounted */
		tseg.drive_name = vl (vX).tape_drive;	/* set-up for insertion */
		tseg.ev_chan = vl (vX).event_chan;
		tseg.ws_segno = vl (vX).ws_segno;
		vl (vX).cflX = 0;			/* invalidate position */
		call unload;
		call mount_request;			/* tell operator to mount */
	     end;
	end;

	return;

write_protect:
     entry (cP, code);				/* set file protect */

	op = "pro";				/* operatio is file _p_r_otect */
	cseg.protect = "1"b;
	go to com;

write_permit:
     entry (cP, code);				/* set file permit */

	op = "per";				/* operation is _p_e_rmit */
	cseg.protect = "0"b;

com:
	on cleanup call cleaner;			/* maintain consistency */
	do vX = 1 to cseg.vcN;			/* test each volume */
	     if vl (vX).rcp_id ^= 0 then do;		/* mounted */
		tseg.drive_name = vl (vX).tape_drive;	/* set-up to use this volume */
		tseg.ws_segno = vl (vX).ws_segno;
		tseg.ev_chan = vl (vX).event_chan;
		call tape_ansi_tape_io_$order (cP, op, 0, code);
						/* set protect or permit */
		if code ^= 0 then
		     go to er_exit;
	     end;
	end;

	return;




free:
     entry (cP, vlX, code);				/* unassign a drive */

	vX = vlX;					/* copy index of current volume link */

	tseg.drive_name = vl (vX).tape_drive;		/* set-up for detach */
	tseg.ev_chan = vl (vX).event_chan;
	tseg.ws_segno = vl (vX).ws_segno;
	vl (vX).cflX = 0;				/* invalidate volume position */
	on cleanup call cleaner;			/* don't leave event channel or drive */

	call tdcm_$tdcm_reset_signal (addr (tseg), 0);
	cseg.wait_switch (vl (vX).rcp_id) = "0"b;
	call tdcm_$tdcm_detach (addr (tseg), code);	/* unassign the drive */
	vl (vX).tape_drive = "";
	vl (vX).rcp_id = 0;
	vl (vX).ws_segno = "0"b;
	if code ^= 0 then
	     go to er_exit;				/* trouble */
	else cseg.nactive = cseg.nactive - 1;		/* ok - down active count */

	call ipc_$delete_ev_chn (tseg.ev_chan, code);	/* delete event channel */
	if code ^= 0 then
	     go to er_exit;				/* trouble */
	vl (vX).event_chan = 0;
	tseg.ev_chan = 0;

	return;

er_exit:
	call cleaner;				/* cleanup if error */
	code = error_table_$bad_mount_request;
	return;


cleaner:
     procedure;					/* cleanup and error exit procedure */
dcl      ecode		  fixed bin (35);

	if tseg.drive_name ^= "" then do;		/* detach drive if attached */
	     call tdcm_$tdcm_reset_signal (addr (tseg), 0);
	     cseg.wait_switch (vl (vX).rcp_id) = "0"b;
	     call tdcm_$tdcm_detach (addr (tseg), ecode);
	     if ecode = 0 then
		cseg.nactive = cseg.nactive - 1;	/* down active count */
	     tseg.drive_name = "";
	     vl (vX).ws_segno = "0"b;
	     vl (vX).tape_drive = "";
	     vl (vX).rcp_id = 0;
	end;
	if tseg.ev_chan ^= 0 then do;			/* delete event channel if created */
	     call ipc_$delete_ev_chn (tseg.ev_chan, 0);
	     tseg.ev_chan = 0;
	     vl (vX).event_chan = 0;
	end;
	vl (vX).cflX = 0;
	return;
     end cleaner;

wait:
     procedure (ecode);				/* waits for tdcm_ interrupt */
dcl      ecode		  fixed bin (35);
dcl      1 wait_list,				/* ipc_$block parameters */
	 2 n		  fixed bin,
	 2 chn		  fixed bin (71);
dcl      1 message,
	 2 channel	  fixed bin (71),
	 2 msg		  fixed bin (71),
	 2 sender		  bit (36),
	 2 origin,
	   3 dev_sig	  bit (18) unaligned,
	   3 ring		  bit (18) unaligned,
	 2 channel_index	  fixed bin;

again:
	wait_list.n = 1;				/* waiting for only 1 interrupt */
	wait_list.chn = tseg.ev_chan;			/* set ID */

	call ipc_$block (addr (wait_list), addr (message), ecode);
						/* wait */
	if ecode ^= 0 then
	     go to reset;				/* always reset the signal */

	tseg.sync = 1;				/* do a synchronous reset status */
	tseg.command_count = 1;
	tseg.buffer_count = 0;
	tseg.command_queue (1) = 100000b;
	call tdcm_$tdcm_iocall (addr (tseg), ecode);

	if tseg.completion_status ^= 1 then
	     go to again;

reset:
	call tdcm_$tdcm_reset_signal (addr (tseg), 0);	/* no more signalling */
	if vl (vX).rcp_id ^= 0 then
	     cseg.wait_switch (vl (vX).rcp_id) = "0"b;

	return;

     end wait;

VOL1_check:
     procedure (ecode);				/* verify VOL1 label */
dcl      ecode		  fixed bin (35),
         data		  char (80) unaligned based (cseg.syncP);
						/* 80 characters of synchronous IO buffer */

	do den = 2 to 4;				/* try to read at 800, 1600, or 6250 bpi */
	     call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);
	     if ecode ^= 0 then
		return;
	     call tape_ansi_tape_io_$order (cP, "sdn", den, ecode);
						/* set density */
	     if ecode = 0				/* if read ok, then ... */
	     then do;
		call tape_ansi_tape_io_$sync_read (cP, i, ecode);
						/* try to read VOL1 label */
		if ecode = 0 then do;		/* read was uneventful */
		     if i >= 80 then do;		/* could be a label */
			if cseg.standard = 1 then
			     cseg.lbl_buf = data;	/* ascii - put in lbl_buf */
			else call ebcdic_to_ascii_ (data, cseg.lbl_buf);
						/* ebcdic - convert move to lbl_buf */
			go to got_it;		/* check whatever we got */
		     end;
		     else do;			/* can't be a VOL1 label */
invalid_VOL1:
			vl (vX).write_VOL1 = 3;	/* indicate not valid VOL1 label */
			go to wvol1;
		     end;
		end;
		else if ecode = error_table_$eof_record then
		     goto invalid_VOL1;
		else if ecode = error_table_$blank_tape then do;
						/* tape is blank */
		     vl (vX).write_VOL1 = 1;		/* indicate blank tape */
		     go to wvol1;
		end;
	     end;
	end;
	vl (vX).write_VOL1 = 2;			/* can't read it (error or 200 or 556 bpi) */

wvol1:
	if cseg.density = -1 then do;			/* no density specified */
	     if cseg.standard = 1 then
		cseg.density = 2;			/* ANSI default is 800 cpi */
	     else cseg.density = 3;			/* IBM default is 1600 bpi */
	end;
	if cseg.density ^= den then do;		/* must set density again */
	     call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);
						/* rewind to set density */
	     if ecode ^= 0 then
		return;
	     call tape_ansi_tape_io_$order (cP, "sdn", (cseg.density), ecode);
						/* set density) */
	end;
	else ecode = 0;
	return;

got_it:
	if VOL1_label_id ^= "VOL1" then
	     go to invalid_VOL1;			/* not VOL1 label */

	if cseg.standard = 1 then do;			/* ANSI - test 80th character */
	     i = cv_dec_check_ (VOL1_80th_char, ecode);	/* convert to binary */
	     if ecode ^= 0 then
		go to invalid_VOL1;			/* not number - invalid */
	     if i < 1 then
		go to invalid_VOL1;			/* must be 1 <_ i <_ 3 */
	     if i > 3 then
		go to invalid_VOL1;
	end;

/*
   if VOL1_volume_id ^= vl (vX).canonical_volname then do; /* identifiers don't match * /
   vl (vX).write_VOL1 = 4;		/* indicate wrong volume identifier * /
   go to wvol1;
   end;
*/

	if (cseg.density = -1) | (cseg.density = den) then do;
						/* all seems well */
	     cseg.density = den;			/* set it to that of the tape */

/* check the format of the VOL1 label for earlier Multics format */

	     ibm_vol1P, ansi_vol1P = addr (cseg.lbl_buf);
	     vl (vX).auth_code = authenticate_ (vl (vX).volname);

	     if cseg.standard = 1 then
		if ansi_vol1.owner_id.auth_code = vl (vX).auth_code then
		     vl (vX).write_VOL1 = 0;
		else vl (vX).write_VOL1 = -1;
	     else if ibm_vol1.owner_id.auth_code = vl (vX).auth_code then
		vl (vX).write_VOL1 = 0;
	     else vl (vX).write_VOL1 = -1;

	     ecode = 0;				/* and no errors */
	     return;				/* so just exit */
	end;

	vl (vX).write_VOL1 = 5;			/* density doesn't match */
	go to wvol1;				/* change tape density to specified value */

     end VOL1_check;

/*
   hdr_eox_check: procedure (ecode);

   dcl  label_id char (4) based (addr (cseg.lbl_buf));


   dcl  data char (80) unaligned based (cseg.syncP),
   i fixed bin,
   j fixed bin,
   ecode fixed bin (35),
   nchar fixed bin;


   /* Enter here after successfully read and verified the VOL1 label. * /
   /* check for file header and trailer labels to complete the tape verification for the ANSI standard * /


   ecode = 0;				/* initialize * /


   do j = 1 to 2;				/* read an 80 char label synchronously: 1st HDR1 then EOX1 * /
   call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read a block looking for HDR1 * /
   if ecode ^= 0 then go to non_standard;	/* trouble already * /
   else do;				/* read was uneventful * /
   if nchar < 80 then go to non_standard; /* definitely not a label * /
   else do;
   if cseg.standard = 1 then cseg.lbl_buf = data; /* move into buffer * /
   else call ebcdic_to_ascii_ (data, cseg.lbl_buf); /* translate to ascii * /
   end;
   if j = 1 then do;		/* looking for HDR1 * /
   if label_id ^= "HDR1" then go to non_standard;
   do i = 1 to 2;		/* get to trailer label position * /
   call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
   /* 1st space past header labels; then past file * /
   if ecode ^= 0 then do;
   /* might be eof: that's ok * /


   end;
   end;
   end;
   end;

   end;
   if label_id = "EOF1" | label_id = "EOV1" then return;
   non_standard:  ecode = error_table_$invalid_file_set_format;
   return;

   end hdr_eox_check;
*/

mount_request:
     procedure;					/* issues mount message to operator and waits */
dcl      msg_temp		  char (66) varying,
         (tdcm_reel_name, save_tdcm_reel_name)
			  char (168),		/* reel name)to/from tdcm_$tdcm_message */
         canon_std		  (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);

once_again:
	call tdcm_$tdcm_set_signal (addr (tseg), code);	/* interrupt when mounted */
	if code ^= 0 then
	     go to er_exit;				/* trouble */
	if cseg.write_ring then
	     part = "a";
	else part = "no";
	call ioa_ ("Mounting volume ^a with ^a write ring.",
						/* write message to user */
	     vl (vX).volname, part);
	if vl (vX).comment = "" then
	     msg_temp = "";
	else msg_temp = ",*" || vl (vX).comment;
	save_tdcm_reel_name, tdcm_reel_name = rtrim (vl (vX).volname) || msg_temp;
	call tdcm_$tdcm_message (addr (tseg), tdcm_reel_name, binary (cseg.write_ring, 17), code);
	if code ^= 0 then
	     go to er_exit;				/* trouble */

	if save_tdcm_reel_name ^= tdcm_reel_name then do;
	     vl (vX).volname = before (tdcm_reel_name, ",");
	     call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (vX).volname, vl (vX).canonical_volname,
		canon_std (standard), code);
	     if code ^= 0 then
		goto er_exit;
	end;

	call wait (code);				/* wait for mount */
	if code ^= 0 then
	     go to er_exit;				/* trouble */
	if cseg.write_ring then
	     call ring_check;			/* did ring get in?? */
	drive_name = tseg.drive_name;
	call ioa_ ("^a mounted on ^a.",		/* inform user */
	     vl (vX).volname, drive_name);

	return;


ring_check:
	procedure;				/* insures that ring is in tape */

/* reset status op in wait procedure set status bits */
	     if substr (hardware_status, 3, 4) = "0000"b then
		if substr (hardware_status, 12, 1) = "1"b then do;
						/* if write protected still... */
		     if can_retry then do;		/* try to remount with ring only once */
			can_retry = "0"b;
			call ioa_ ("^a mounted without ring - retrying.",
						/* tell user */
			     vl (vX).volname);
			call unload;
			go to once_again;		/* retry the mount */
		     end;
		     else do;			/* 2nd try failed as well */
			code = error_table_$bad_mount_request;
			go to er_exit;
		     end;
		end;

	     return;				/* ring is in tape */

	end ring_check;

     end mount_request;



unload:
     procedure;					/* unloads a drive */

	call tape_ansi_tape_io_$order (cP, "run", 0, code);
						/* will wait for, but not set, signal */
	if code ^= 0 then
	     go to er_exit;

	call tdcm_$tdcm_reset_signal (addr (tseg), 0);	/* redundant, but just in case... */
	cseg.wait_switch (vl (vX).rcp_id) = "0"b;

	return;

     end unload;


     end tape_ansi_mount_cntl_;




		    tape_ansi_nl_file_cntl_.pl1     12/17/86  0926.4r w 12/17/86  0829.4      383580



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





/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/*                                                                    */
/*  tape_ansi_nl_file_cntl_                                                     */
/*                                                                    */
/*       Main logic module of tape_ansi_ for unlabeled volumes.  See  */
/*  individual entries for details of use and calling sequence.       */
/*                                                                    */
/*  0) Created:   10/04/74 by Ross E. Klinger                         */
/*  1) Modified:  10/04/74 by C. D. Tavares for resource management   */
/*  2) Modified: 06/29/79 by Rick Riley                               */
/*               (to allow reading/writing unlabeled ibm file sets    */
/*  3) Modified:  9/79	by R.J.C. Kissel for new tseg.	*/
/*  4) Modified:  4/82 by J. A. Bush for block sizes > 8192 bytes     */
/*                                                                    */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */


/* format: style3,ind3,dclind6,idind32 */
tape_ansi_nl_file_cntl_:
   procedure;					/* This entry not used */

/* arguments */
dcl   iocbP		        ptr,		/* pointer to iocb */
      open_mode		        fixed bin,		/* opening mode */
      extend_bit		        bit (1) aligned,	/* extend at open time */
      code		        fixed bin (35);	/* error code */

%include iocb;

%include tape_ansi_cseg;

%include tape_ansi_fd;

%include ibm_hdr1;

%include rcp_volume_formats;

%include rcp_resource_types;


/* automatic storage */
dcl   answer		        char (128) varying,
      com_text		        char (64) varying,
      vn			        char (32),
      cc			        fixed bin,		/* consistency code */
						/* 0 - invalidate volume position */
						/* 1 - invalidate volume position and current file link */
						/* 2 - invalidate position, current file link, write EOV TM */
      mask		        bit (36) aligned,
      tstring		        char (32) varying;	/* open description temporary */

dcl   1 qi		        aligned,		/* query info structure */
        2 version		        fixed bin init (2),
        2 yes_no		        bit (1) unaligned,
        2 suppress_name	        bit (1) unaligned,
        2 scode		        fixed bin (35),
        2 qcode		        fixed bin (35) init (0);

/* internal static */
dcl   debug		        bit (1) internal static initial ("0"b);
						/* debug switch */


/* conditions */
dcl   (any_other, cleanup)	        condition;

/* builtin functions */
dcl   (addr, index, length, ltrim, mod, null, substr)
			        builtin;

/* external procedures */
dcl   canon_for_volume_label_	        ext entry (char (*), char (*), char (*), fixed bin, fixed bin (35)),
      command_query_	        ext entry options (variable),
      continue_to_signal_	        ext entry (fixed bin (35)),
      tape_ansi_control_	        ext entry (ptr, char (*), ptr, fixed bin (35)),
      tape_ansi_detach_	        ext entry (ptr, fixed bin (35)),
      tape_ansi_nl_file_cntl_$close   ext entry (ptr, fixed bin (35)),
      tape_ansi_nl_file_cntl_$open    ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)),
      hcs_$reset_ips_mask	        ext entry (bit (36) aligned, bit (36) aligned),
      hcs_$set_ips_mask	        ext entry (bit (36) aligned, bit (36) aligned),
      tape_ansi_ibm_lrec_io_$close    ext entry (ptr, fixed bin (35)),
      tape_ansi_ibm_lrec_io_$read_record
			        ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
      tape_ansi_ibm_lrec_io_$write_record
			        ext entry (ptr, ptr, fixed bin (21), fixed bin (35)),
      ioa_		        ext entry options (variable),
      iox_$propagate	        ext entry (ptr),
      tape_ansi_mount_cntl_$mount     ext entry (ptr, fixed bin, fixed bin (35)),
      tape_ansi_mount_cntl_$remount   ext entry (ptr, fixed bin, fixed bin, fixed bin (35)),
      tape_ansi_position_	        ext entry (ptr, fixed bin, fixed bin (21), fixed bin (35)),
      tape_ansi_read_length_	        ext entry (ptr, fixed bin (21), fixed bin (35)),
      tape_ansi_tape_io_$open	        ext entry (ptr),
      tape_ansi_tape_io_$order        ext entry (ptr, char (3), fixed bin, fixed bin (35)),
      terminate_process_	        ext entry (char (*), ptr);


/* external static */
dcl   (
      error_table_$blank_tape,
      error_table_$device_limit_exceeded,
      error_table_$end_of_info,
      error_table_$eov_on_write,
      error_table_$file_aborted,
      error_table_$file_busy,
      error_table_$incompatible_attach,
      error_table_$incompatible_encoding_mode,
      error_table_$insufficient_open,
      error_table_$invalid_block_length,
      error_table_$invalid_cseg,
      error_table_$invalid_file_set_format,
      error_table_$invalid_record_length,
      error_table_$no_file,
      error_table_$no_next_volume,
      error_table_$positioned_on_bot,
      error_table_$unable_to_do_io,
      error_table_$uninitialized_volume
      )			        fixed bin (35) ext static;

dcl   sys_info$max_seg_size	        fixed bin (35) external static;

open:
   entry (iocbP, open_mode, extend_bit, code);

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to control segment */

      if cseg.invalid
      then
         do;					/* is control segment invalid? */
	  code = error_table_$invalid_cseg;
	  return;
         end;

      if cseg.file_lock
      then
         do;					/* is file in use (by previous invocation)? */
	  code = error_table_$file_busy;
	  return;
         end;
      else
         do;
	  cc = 0;					/* minimal consistency requirement */
	  on cleanup
	     begin;				/* insure file chain <--> tape consistency */
	        call consistent;
	        cseg.file_lock = "0"b;		/* unlock the file */
	     end;
	  cseg.file_lock = "1"b;			/* not in use - now it is */
         end;

      if extend_bit
      then
         do;					/* extend at open time not allowed */
bad_open:
	  code = error_table_$incompatible_attach;
	  go to valid_exit;
         end;

      if open_mode = 4
      then tstring = "sequential_input";		/* set for sequential input */
      else
         do;					/* sequential output or input_output */
	  if cseg.output_mode = 0
	  then go to bad_open;			/* no output mode specified */
	  if open_mode = 5
	  then tstring = "sequential_output -create";
	  else go to bad_open;
         end;

      cseg.open_mode = open_mode;			/* save open mode in control segment */

/*  OLD  */
      cseg.flP = null;
      fd.vlX = 1;

/*  OLD  */
/*  NEW  * /
      cseg.flP = null;				/*  set the file index pointer no there are none * /
      if fd.vlX = 0
      then
         do;					/* if the vol index not set then set it * /
	  fd.vlX = 1;				/* set to initial vol and first file * /
	  vl (1).fflX = 1;
	  go to found_it;
         end;

      if append_file ()
      then
         do;					/* when writeing a file we need to find the file * /
	  do i = 1 to cseg.vcN;			/* search forward for the file * /
	     if vl (i).fflX ^= 0
	     then /* only searching vols that have files * /
		if (fd.sequence >= vl (i).fflX & (fd.sequence <= vl (i).lflX + 1 | vl (i).lflX = 0))
		then
		   do;				/* then test for a file fit on the volume * /
		      fd.vlX = i;
		      if vl (i).lflX = 0 | fd.sequence <= vl (i).lflX
		      then go to found_it;		/* if a new file keep looking * /
		      else
		         do j = i to cseg.vcN;	/* look until you find the volume.
						   New files can only be 1+ the last written * /
			  if vl (j).fflX ^= 0
			  then if (fd.sequence >= vl (j).fflX & (fd.sequence <= vl (j).lflX + 1 | vl (j).lflX = 0))
			       then fd.vlX = j;
		         end;
		      go to found_it;
		   end;
	  end;
	  code = error_table_$no_file;
	  go to er_exit;
         end;

      else
         do i = 1 to cseg.vcN;			/* check for the desired file in the volume index list
						   and first and last of the vols * /
	  if vl (i).fflX = 0
	  then go to no_find;
	  if (fd.sequence >= vl (i).fflX & fd.sequence <= vl (i).lflX) | (fd.sequence >= vl (i).fflX & vl (i).lflX = 0)
	  then
	     do;					/* want volume file first appears on * /
	        fd.vlX = i;
	        go to found_it;
	     end;

         end;
no_find:
      code = error_table_$no_file;
      go to er_exit;

found_it:
/*  NEW  */
      if cseg.open_mode = 4
      then
         do;					/* input */
	  if fd.format = 0
	  then
	     do;
not_enough:
	        code = error_table_$insufficient_open;
	        go to valid_exit;
	     end;
	  if fd.blklen = 0
	  then go to not_enough;
	  if fd.reclen = 0
	  then
	     do;
	        if fd.format = 1
	        then ;
	        else go to not_enough;
	     end;
	  if fd.mode = 0
	  then fd.mode = 2;


	  call move (fd.vlX, fd.sequence, code);	/* move to the file */
	  if code ^= 0
	  then go to er_exit;
	  call lrec_open;
         end;

      else
         do;					/* output */
	  if fd.format = 0
	  then
	     do;
	        fd.format = 3;
	        fd.blocked = "1"b;
	     end;
	  if fd.blklen = 0
	  then fd.blklen = 8192;
	  if fd.reclen = 0
	  then
	     do;
	        if fd.format = 1
	        then ;
	        else if fd.format = 2
	        then fd.reclen = fd.blklen;
	        else if fd.format = 3
	        then fd.reclen = 8188;
	        else fd.reclen = sys_info$max_seg_size * 4;
	     end;
	  if fd.mode = 0
	  then fd.mode = 2;

	  call move (fd.vlX, fd.sequence, code);	/* move to the file */
	  if code ^= 0
	  then go to er_exit;			/*  NEW  * /

	  do i = fd.vlX + 1 to cseg.vcN;		/* reinit the vol indexes above this last file * /
	     call vl_init (i);
	  end;
/*  NEW  */
	  call lrec_open;
         end;

done:
      mask = "0"b;					/* ips interrupts not masked yet */
      cseg.open_description.length = length (tstring);	/* prepare open description */
      cseg.open_description.string = tstring;
      revert cleanup;
      on any_other call handler;			/* pick up any condition */
      call hcs_$set_ips_mask ("0"b, mask);		/* mask all ips interrupts */
      iocbP -> iocb.actual_iocb_ptr -> iocb.close = tape_ansi_nl_file_cntl_$close;
      if cseg.open_mode = 5
      then iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_ibm_lrec_io_$write_record;
      else
         do;					/* sequential input */
	  iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_ibm_lrec_io_$read_record;
	  iocbP -> iocb.actual_iocb_ptr -> iocb.read_length = tape_ansi_read_length_;
	  iocbP -> iocb.actual_iocb_ptr -> iocb.position = tape_ansi_position_;
         end;
      iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (cseg.open_description);
      call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
      call hcs_$reset_ips_mask (mask, mask);		/* permit ips interrupts */
      cseg.file_lock = "0"b;				/* open complete - unlock the file */
      return;

er_exit:
      call consistent;
      go to valid_exit;


no_next_volume:
      code = error_table_$no_next_volume;


valid_exit:
      cseg.file_lock = "0"b;				/* open complete - unlock the file */
      return;					/*  NEW  * /

append_file:
   procedure returns (bit (1));

      if debug
      then call debug_print ("append_file");
      if cseg.open_mode ^= 5
      then return ("0"b);
      if cseg.output_mode ^= 4
      then return ("0"b);

      return ("1"b);

   end append_file;

/*  NEW  */
abort_file:
   procedure;					/* cleanup after defective file */
      if debug
      then call debug_print ("abort_file");

      vl (fd.vlX).cflX = 0;				/* invalidate volume position */

/*  OLD  */
      call write_TM (2, code);			/* write the TMs */
						/*  OLD  */
						/*  NEW  * /
      call write_TM (3, code);			/* write the TMs * /
/*  NEW  */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then go to abort_fail;

/*  OLD  */
      call ioa_ ("^a: Unrecoverable error while writing file; double TM written.", cseg.module);
						/*  OLD  */
						/*  NEW  * /
      call ioa_ ("^a: Unrecoverable error while writing file; triple TM written.", cseg.module);
						/*  NEW  */
      code = error_table_$file_aborted;
      return;

abort_fail:
      call ioa_ ("^a: Unrecoverable error while writing file; unable to write double TM.", cseg.module);
      code = error_table_$invalid_file_set_format;
      return;

   end abort_file;

consistent:
   procedure;					/* insures file chain/tape consistency */
      if debug
      then call debug_print ("consistent");

      go to recovery (cc);				/* perform appropriate consistency processing */

recovery (0):
      return;


recovery (1):
      if fd.vlX ^= 0
      then vl (fd.vlX).cflX = 0;			/* invalidate volume position */
      return;

recovery (2):
      if fd.vlX = 0
      then return;					/* nothing can be done - exit */
      call abort_file;				/* write end of volume TMs */
      return;

   end consistent;

handler:
   procedure;					/* intercept any faults during iocb manipulation */
dcl   1 ti		        aligned,
        2 version		        fixed bin init (0),
        2 code		        fixed bin (35);

      if mask ^= "0"b
      then
         do;					/* IPS interrupts masked */
	  ti.code = error_table_$unable_to_do_io;	/* very bad trouble */
	  call terminate_process_ ("fatal_error", addr (ti));
						/* kill the process */
         end;
      call continue_to_signal_ (0);
      return;
   end handler;

initialize_permitA:
   procedure (vX) returns (bit (1));			/* query to initialize unexpired volume */

dcl   vX			        fixed bin;
dcl   msg			        char (120) varying;
dcl   msg1		        char (length (msg)) based (addr (substr (msg, 1)));

      msg = "Volume ^a has a valid VOL1 label.^/Do you want to use this volume for unlabeled output?";
      go to ip_com;


initialize_permitB:
   entry (vX) returns (bit (1));			/* query to initialize an unreadable volume */

      msg = "Cannot determine if volume ^a has a VOL1 label.^/Do you want to use this volume for unlabeled output?";

ip_com:
      qi.yes_no = "1"b;
      qi.suppress_name = "0"b;
      qi.scode = error_table_$uninitialized_volume;

      call command_query_ (addr (qi), answer, cseg.module, msg1, vl (vX).volname);

      if answer = "yes"
      then return ("1"b);
      else return ("0"b);

   end initialize_permitA;

lrec_open:
   procedure;					/* logical record IO initialization and final checks */
      if debug
      then call debug_print ("lrec_open");

      if cseg.open_mode > 4
      then if fd.blklen < 18
	 then go to inv_blk;			/* can't write < 18 chars */

      if cseg.open_mode > 4
      then if mod (fd.blklen, 4) ^= 0
	 then go to inv_blk;			/* can only write words */
      if fd.mode = 3
      then cseg.mode = 0;				/* binary mode is set */
      else cseg.mode = 1;				/* ascii, ebcdic encoding 9 mode */

      go to match (fd.format);			/* match the blocking */
match (2):
      if ^fd.blocked
      then if fd.blklen ^= fd.reclen
	 then go to inv_rec;			/* F unblocked */
	 else go to ok;
      else if mod (fd.blklen, fd.reclen) ^= 0
      then go to inv_rec;				/* F blocked */
      else go to ok;

match (3):
      if ^fd.blocked
      then if fd.blklen - 4 ^= fd.reclen
	 then go to inv_rec;
	 else go to ok;
      else if fd.reclen > fd.blklen - 4
      then go to inv_rec;				/* V blocked */
      else go to ok;

match (4):
      if fd.reclen > sys_info$max_seg_size * 4
      then go to inv_rec;				/* S format */

match (1):
ok:
      cseg.rlN = -1;				/* invalidate anything in rl segment */
      cseg.lrec.bufP = null;				/* no active buffer */
      cseg.blkcnt = 0;
      cseg.lrec.reccnt = 0;				/* not currently used */
      cseg.lrec.code = 0;				/* no errors encountered */
      call tape_ansi_tape_io_$open (cP);		/* initialize call to tape_ansi_tape_io_ */
      return;					/* exit */

inv_rec:
      code = error_table_$invalid_record_length;
      go to er_exit;
inv_blk:
      code = error_table_$invalid_block_length;
      go to er_exit;
bad_mode:
      code = error_table_$incompatible_encoding_mode;
      go to er_exit;

   end lrec_open;

move:
   procedure (vX, fX, ecode);
      if debug
      then call debug_print ("move");
dcl   vX			        fixed bin,		/* volume link index of desired volume */
      fX			        fixed bin,		/* sequence number of desired file */
      ecode		        fixed bin (35);	/* error code */
dcl   i			        fixed bin,
      uninit_msg		        char (28) varying;
      cc = 0;
      if vl (vX).rcp_id = 0
      then
         do;					/* volume is not mounted */
	  if cseg.nactive < cseg.ndrives
	  then
	     do;					/* more drives available */
	        call tape_ansi_mount_cntl_$mount (cP, vX, ecode);
						/* mount the volume */
	        if ecode ^= 0
	        then
		 do;				/* maybe trouble */
		    if ecode = error_table_$device_limit_exceeded
		    then
		       do;
			cseg.ndrives = cseg.ndrives - 1;
						/* decrement maximum device count */
			go to switch;
		       end;
		    else go to error;		/* true trouble */
		 end;
	     end;
	  else
	     do;					/* no drive available */
switch:
	        do i = 1 to vX - 1;			/* search up to desired volume */
		 if vl (i).rcp_id ^= 0
		 then go to got_one;		/* got one active */
	        end;
	        do i = cseg.vcN to vX + 1 by -1;	/* search down to desired volume */
		 if vl (i).rcp_id ^= 0
		 then go to got_one;		/* got one active */
	        end;
	        ecode = error_table_$invalid_cseg;	/* something very wrong if no volume found */
	        go to error;
got_one:
	        call tape_ansi_mount_cntl_$remount (cP, i, vX, ecode);
						/* remount the volume */
	        if ecode ^= 0
	        then go to error;			/* trouble */
	     end;
         end;

      cseg.tseg.drive_name = vl (vX).tape_drive;
      cseg.tseg.ev_chan = vl (vX).event_chan;
      fd.vlX = vX;

      if cseg.open_mode = 5
      then
         do;					/* check for VOL1 only if output */
	  if vl (vX).write_VOL1 = 1
	  then ;					/* tape is blank */
	  else if vl (vX).write_VOL1 = 3
	  then ;					/* no VOL1 label */
	  else
	     do;					/* has VOL1 label, or can't tell */
	        if fX ^= 1
	        then
		 do;				/* can't initialize if not first file on volume */
		    if vl (vX).write_VOL1 = 2
		    then uninit_msg = "is unreadable";
		    else uninit_msg = "is not an unlabeled volume";
		    call ioa_ ("^a: Volume ^a ^a.", cseg.module, vl (vX).volname, uninit_msg);
uninit:
		    code = error_table_$uninitialized_volume;
		    go to error;
		 end;
	        go to iq (vl (vX).write_VOL1);
iq (6):
iq (0):
iq (4):
iq (5):
iq (-1):
	        if initialize_permitA (vX)
	        then go to ok;
	        else go to uninit;
iq (2):
	        if ^initialize_permitB (vX)
	        then go to uninit;
ok:
	        call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);
	        if ecode ^= 0
	        then go to error;			/*  OLD  */
	        call write_TM (2, ecode);		/*  OLD  */
						/*  NEW  * /
	        call write_TM (3, ecode);		/* write the init end of vol set TMs * /
/*  NEW  */
	        if ecode ^= 0
	        then if ecode ^= error_table_$eov_on_write
		   then go to error;		/*  OLD  */
	        vl (vX).cflX = 3;			/*  OLD  */
						/*  NEW  * /
	        vl (vX).cflX = vl (vX).fflX + 3;	/* set current to three after the first file   * /
/*  NEW  */
	        vl (vX).write_VOL1 = 3;
	     end;
         end;

      if vl (vX).cflX = 0
      then
         do;					/* volume position unknown */
	  call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);
	  if ecode ^= 0
	  then go to error;				/*  OLD  */
	  vl (vX).cflX = 1;				/*  OLD  */
						/*  NEW  * /
	  vl (vX).cflX = vl (vX).fflX;		/* after rewind set file index to first file on volume * /
	  if fX = vl (vX).cflX
	  then go to ok_exit;			/* if we are where we want to be at the beginning go on * /
/*  NEW  */
         end;

      if vl (vX).cflX < fX
      then
         do;					/* volume positioned before desired file */
	  do i = 1 to fX - vl (vX).cflX;
	     call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
	     if ecode ^= 0
	     then
	        do;
		 if ecode = error_table_$blank_tape
		 then ecode = error_table_$no_file;
		 go to error;
	        end;				/*  OLD  */
	  end;					/*  OLD  */
						/*  NEW  * /

/* when searching forward and the volume indexes
   are not set then need to read a record looking for
   eov or eov_set * /


	     if vl (fd.vlX).lflX = 0
	     then
	        do;				/* check for index not set * /
		 call tape_ansi_tape_io_$sync_read (cP, nchar, ecode);
						/* read a record * /
		 if ecode ^= 0
		 then
		    do;				/* not eof error then error return * /
		       if ecode ^= error_table_$eof_record
		       then go to error;
		       else call tape_ansi_tape_io_$sync_read (cP, nchar, ecode);
						/* read again hope its a label * /

		       if ecode ^= 0
		       then
			do;
			   if ecode = error_table_$eof_record
			   then
			      do;			/* if a third eof then we know endofvolset * /
			         ecode = error_table_$no_file;
						/* set the erorror mseg * /
			         vl (fd.vlX).lflX = vl (fd.vlX).cflX + i - 1;
						/* set the vol index * /
			         vl (fd.vlX).cflX = vl (fd.vlX).lflX + 3;
			         if append_file ()
			         then
				  do;		/* check if appending to the last file * /
				     if fX ^= vl (fd.vlX).lflX + 1
				     then return;	/* its okay for last +1 * /
				     else ecode = 0;
				     go to appending;
				  end;

			         else return;
			      end;

			   else go to error;
			end;

		       if cseg.standard = 1
		       then cseg.lbl_buf = sync_buf;	/* convert ebcdic label * /
		       else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf);

		       if substr (lbl_buf, 1, 4) ^= "EOV1"
		       then
			do;			/* is this a label or not * /
			   ecode = error_table_$invalid_file_set_format;
						/* maybe messed up * /
			   return;
			end;

		       if debug
		       then call ioa_ ("^80a", lbl_buf);

/* mount the next volume * /
/* set the volume indexes as you know them * /
		       vl (fd.vlX).lflX = vl (fd.vlX).cflX + i - 1;

		       if ^next_volume ()
		       then
			do;
			   ecode = error_table_$no_next_volume;
			   return;
			end;

		       fd.vlX = fd.vlX + 1;
		       vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX;
		       vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX;
		       vl (fd.vlX - 1).cflX = 0;
appending:
		       call move (fd.vlX, fd.sequence, ecode);
						/* find the file now * /
		       if ecode ^= 0
		       then go to error;
		       else go to move_done;
		    end;
	        end;

	  end;
move_done:
	  call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
	  if ecode ^= 0
	  then go to error;
	  call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
	  if ecode ^= 0
	  then go to error;


/*  NEW  */
         end;

      else if vl (vX).cflX > fX
      then
         do;					/* volume positioned after desired file */
	  do i = 1 to vl (vX).cflX - fX;
	     call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
	     if ecode ^= 0
	     then go to error;
	  end;
	  call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
	  if ecode = 0
	  then
	     do;
	        call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
	        if ecode ^= 0
	        then go to error;
	     end;
	  else if ecode = error_table_$positioned_on_bot
	  then ecode = 0;
	  else go to error;
         end;

      else
         do;					/* volume positioned at desired file */
	  if fX = 1
	  then
	     do;
	        call tape_ansi_tape_io_$order (cP, "rew", 0, ecode);
	        if ecode ^= 0
	        then go to error;
	     end;
	  else
	     do;
	        call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode);
	        if ecode ^= 0
	        then go to error;
	        call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode);
	        if ecode ^= 0
	        then go to error;
	     end;
         end;

ok_exit:
      vl (vX).cflX = fX;				/* new position info */
      return;

error:
      vl (vX).cflX = 0;				/* we don't know where we are */
      return;
   end move;

next_volume:
   procedure returns (bit (1));			/* determines if volume switch possible */

dcl   canon_std		        (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape);
dcl   ecode		        fixed bin (35);

      if debug
      then call debug_print ("next_volume");

      if fd.vlX < cseg.vcN
      then return ("1"b);				/* if current vlX < vcN then next exists */

      if fd.vlX = 63
      then
         do;					/* volume chain full */
	  call ioa_ ("^a: Implementation limit of 63 volumes has been reached.", cseg.module);
	  return ("0"b);
         end;

      if another_volume ()
      then vl (cseg.vcN + 1).comment = com_text;		/* yes  */
      else return ("0"b);				/* user said terminate */

got_reelid:
      cseg.vcN = cseg.vcN + 1;			/* increment volume link count */
      call vl_init (cseg.vcN);
      vl (cseg.vcN).volname = vn;			/* set volume name in volume link */
      call
         canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vn, vl (cseg.vcN).canonical_volname,
         canon_std (cseg.standard), ecode);
      if ecode ^= 0
      then return (""b);

      return ("1"b);

   end next_volume;

vl_init:
   procedure (n);					/* initialize a volume link */
dcl   n			        fixed bin;		/* link index */
      vl (n).fflX = 0;
      vl (n).cflX = 0;
      vl (n).pos = 0;
      vl (n).lflX = 0;
      vl (n).tracks = 0;
      vl (n).density = 0;
      vl (n).label_type = 0;
      vl (n).usage_count = 0;
      vl (n).read_errors = 0;
      vl (n).write_errors = 0;
      vl (n).rcp_id = 0;
      vl (n).event_chan = 0;
      vl (n).tape_drive = "";
      vl (n).write_VOL1 = 0;
      vl (n).ioi_index = 0;
      return;
   end vl_init;

another_volume:
   procedure returns (bit (1));			/* queries user for next volume name */

dcl   msg			        char (80) varying;	/* message to user */
dcl   msg1		        char (length (msg)) based (addr (substr (msg, 1)));
						/* char (*) overlay for command_query_ */
dcl   L1			        fixed bin;

      qi.yes_no = "1"b;				/* want yes or no */
      qi.suppress_name = "0"b;			/* don't suppress module name */
      qi.scode = error_table_$no_next_volume;
      msg = "Reached end of volume.  Do you wish to terminate processing of this volume-set?";
      call command_query_ (addr (qi), answer, cseg.module, msg1);

      if answer = "yes"
      then return ("0"b);				/* finito */

      qi.yes_no = "0"b;				/* don't want yes or no */
      qi.suppress_name = "1"b;
ask:
      qi.scode = 0;					/* no scode when asking for name */
      msg = "Enter volume name of next volume (and optional comment).^/";
ask_raw:
      call command_query_ (addr (qi), answer, cseg.module, msg1);
      if answer = ""
      then go to ask;
      com_text = "";				/* initialize comment message */
      L1 = index (answer, " ") - 1;			/* scan for a blank */
      if L1 < 0
      then L1 = length (answer);

      call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, L1), vn, 0, code);
      if code ^= 0
      then
         do;
	  qi.scode = code;
	  msg = substr (answer, 1, L1) || "^/Enter volume name of next volume (and optional comment).^/";
	  go to ask_raw;
         end;

      answer = ltrim (substr (answer, L1 + 1));
      if substr (answer, 1, 8) = "-comment"
      then
         do;
	  answer = ltrim (substr (answer, 10));
	  go to comment;
         end;
      if substr (answer, 1, 4) = "-com"
      then
         do;
	  answer = ltrim (substr (answer, 6));
comment:
	  if length (answer) = 0
	  then ;					/* no comment */
	  else com_text = answer;
         end;
      else
         do;					/* invalid comment */
	  call ioa_ ("Comment is invalid.");

	  go to ask;
         end;

      return ("1"b);				/* volume name is ok - exit */

   end another_volume;

write_TM:
   procedure (n, ecode);				/* writes 1 or 2 TM and adjusts volume link */
dcl   n			        fixed bin,		/* number of TM - 1 or 2 */
      cnt			        fixed bin,
      ecode		        fixed bin (35);

      if debug
      then call ioa_ ("write_TM ^d", n);
      do cnt = 1 to n;				/* 1 or 2 */
         call tape_ansi_tape_io_$order (cP, "eof", 0, ecode);
						/* write a TM */
         if ecode ^= 0
         then if ecode ^= error_table_$eov_on_write
	    then return;				/* error exit */
         vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1;
      end;

      return;

   end write_TM;

beginning_of_file:
   entry (iocbP, code);				/* positions to beginning of file */

      if debug
      then call debug_print ("bof");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to cseg */

      cc = 0;
      on cleanup go to bof_fail;

      call tape_ansi_ibm_lrec_io_$close (cP, code);	/* close logical record I/O */
      if code ^= 0
      then go to bof_fail;

/*  OLD  */
      call move (1, fd.sequence, code);			/* move the tape */
						/*  OLD  */
						/*  NEW  * /
	  do i = 1 to cseg.vcN;			/* determine where the file begins and have that vol mounted * /
         if fd.sequence >= vl (i).fflX & fd.sequence <= vl (i).lflX
         then
	  do;
	     fd.vlX = i;
	     go to got_vol;
	  end;
      end;					/* if not found in loop then it is the current volume * /

got_vol:						/* if no volume found use the current one * /
      call move (fd.vlX, fd.sequence, code);		/* move the tape * /
/*  NEW  */
      if code ^= 0
      then
         do;
bof_fail:
	  call consistent;
	  go to close_exit;
         end;

      call lrec_open;				/* re-initialize to open logical record I/O */
						/* note - no error can occur in this call */

      return;

end_of_file:
   entry (iocbP, code);				/* positions to end of file */

      if debug
      then call debug_print ("end_of_file");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get pointer to cseg */

      cc = 0;
      on cleanup go to eof_fail;

      if cseg.lrec.code = error_table_$end_of_info
      then
         do;					/* passed eof */
	  call tape_ansi_tape_io_$order (cP, "bsf", 0, code);
	  if code ^= 0
	  then go to eof_fail;
	  else vl (fd.vlX).cflX = vl (fd.vlX).cflX - 1;
	  return;
         end;

      cseg.rlN = -1;				/* invalidate any record in real_length buffer */
      cseg.blkcnt = -1;				/* invalidate the block count */

      call tape_ansi_ibm_lrec_io_$close (cP, code);	/* close logical record io */
      if code ^= 0
      then
         do;
eof_fail:
	  call consistent;
	  go to close_exit;
         end;

/*  OLD  */
      if fd.vlX ^= cseg.vcN
      then
         do;					/* not at last volume of file */
	  call move (cseg.vcN, 1, code);
	  if code ^= 0
	  then go to eof_fail;
         end;

      call tape_ansi_tape_io_$order (cP, "fsf", 0, code);
      if code ^= 0
      then go to eof_fail;				/*  OLD  */
						/*  NEW  * /
	     do i = 1 to cseg.vcN;			/* search forward for the next file * /
         if vl (i).fflX ^= 0
         then /* only searching vols that have files * /
	    if (fd.sequence + 1 >= vl (i).fflX & (fd.sequence + 1 <= vl (i).lflX + 1 | vl (i).lflX = 0))
	    then
	       do;				/* then test for a file fit on the volume * /
		fd.vlX = i;
		if vl (i).lflX = 0 | fd.sequence + 1 <= vl (i).lflX
		then go to got_tape;		/* it may be after the last file in the file set * /
		else
		   do j = i to cseg.vcN;		/* look until you find the volume.
						   New files can only be 1+ the last written * /
		      if vl (j).fflX ^= 0
		      then if (fd.sequence + 1 >= vl (j).fflX & (fd.sequence + 1 <= vl (j).lflX + 1 | vl (j).lflX = 0))
			 then fd.vlX = j;
		   end;
		go to got_tape;
	       end;
      end;					/* if we fall through search on from where we are * /
got_tape:						/* move to the next sequential file then back up
						   to be at end of desired file  * /
      call move (fd.vlX, fd.sequence + 1, code);
      if code ^= 0
      then go to eof_fail;

/*  NEW  */
      call tape_ansi_tape_io_$order (cP, "bsf", 0, code);
      if code ^= 0
      then go to eof_fail;				/*  NEW  * /
	        else vl (fd.vlX).cflX = vl (fd.vlX).cflX - 1;


	        call lrec_open;			/* re-initialize to open record io * /

/*  NEW  */
      return;					/*       */
data_eof:
   entry (iocbP, code);				/* called by ibm_lrec io when
						   read returns an eof_record */
      if debug
      then call debug_print ("data_eof");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get control segment pointer */

      cc = 0;					/* minimal consistency requirement */
      on cleanup go to data_eof_fail;

      vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1;		/* have moved over a TM - update position info */


      call tape_ansi_ibm_lrec_io_$close (cP, code);
      if code ^= 0
      then
         do;
data_eof_fail:
	  call consistent;
	  go to close_exit;
         end;

/*  OLD  */
      if fd.vlX = cseg.vcN
      then
         do;					/* last (or only) section */
						/*  OLD  */
						/*  NEW  * /
		    call tape_ansi_tape_io_$sync_read (cP, nchar, code);
						/* read the next 80 chars looking for eov label * /

      if code ^= 0
      then
         do;

	  if code = error_table_$eof_record
	  then
	     do;					/* if another eof then this maybe end of vol set * /
	        vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1;
	        call tape_ansi_tape_io_$sync_read (cP, nchar, code);
						/* read again to see if another eof * /
	        if code = error_table_$eof_record
	        then
		 do;				/* if another eof then end of vol set emit end_of_info * /
		    vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1;
						/* update volume positions * /
		    vl (fd.vlX).lflX = vl (fd.vlX).cflX - 3;
		    code = error_table_$end_of_info;
		    return;
		 end;
	        else if code ^= 0
	        then go to data_eof_fail;

	        if cseg.standard = 1
	        then cseg.lbl_buf = sync_buf;
	        else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf);
						/* convert the  ebcdic label buffer  * /


	        if substr (lbl_buf, 1, 4) ^= "EOV1"
	        then
		 do;				/* if not a label then just end of file and go on * /
		    code = error_table_$end_of_info;
		    return;
		 end;

	     end;

	  else go to data_eof_fail;			/* if error then go to error handle * /
         end;

      else
         do;					/* this is simple end of file case go back * /
/*  NEW  */
	  code = error_table_$end_of_info;
	  return;
         end;

/*  OLD  */
      call move (fd.vlX + 1, 1, code);			/* move to next volume */
						/*  OLD  */
						/*  NEW  * /


	        if debug
	        then call ioa_ ("^80a", lbl_buf);


/* this is end of volume prepare to mount
   the next volume in the set * /

      if ^next_volume ()
      then
         do;
	  code = error_table_$no_next_volume;
	  return;
         end;

      if vl (fd.vlX).lflX = 0
      then vl (fd.vlX).lflX = vl (fd.vlX).cflX - 2;	/* check last file index * /
      else if vl (fd.vlX).lflX ^= vl (fd.vlX).cflX - 2
      then
         do;					/* if not set set it right if set check it * /
	  code = error_table_$invalid_file_set_format;
	  go to data_eof_fail;
         end;

      vl (fd.vlX).cflX = 0;				/* invalidate this volume position  * /
      fd.vlX = fd.vlX + 1;				/* increment to next volume   * /
      vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX;		/* update volume index info * /
      vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX;
      call move (fd.vlX, fd.sequence, code);
/*  NEW  */
      if code ^= 0
      then go to data_eof_fail;

      return;

data_eot:
   entry (iocbP, code);				/* called by lrec IO when  a write encounters EOT */

      if debug
      then call debug_print ("data_eot");
      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/*  get pointer to control segment */

      if ^next_volume ()
      then
         do;					/* no next volume available */
	  code = error_table_$no_next_volume;
	  return;
         end;

      cc = 2;					/* don't leave defective tape file */
      on cleanup go to data_eot_fail;

/*  OLD  */
      call write_TM (1, code);			/* write end-of-data TM */
						/*  OLD  */
						/*  NEW  * /
	        vl (fd.vlX).lflX = vl (fd.vlX).cflX;	/* set the last file index counter * /

      call write_EOV1 (code);				/* call write_EOV to write  end of vol trail...
						   two tape marks, an eov label, and a tape mark * /
/*  NEW  */
      if code ^= 0
      then if code ^= error_table_$eov_on_write
	 then
	    do;					/* trouble - ignore EOT) */
data_eot_fail:
	       call consistent;
	       go to close_exit;			/* force close */
	    end;
      cc = 0;

/*  OLD  */
      call move (fd.vlX + 1, 1, code);			/* move to beginning of next volume */
						/*  OLD  */
						/*  NEW  * /
						/* set up for mounting the next volume * /
      vl (fd.vlX).cflX = 0;				/* invalidate this volume position  * /
      fd.vlX = fd.vlX + 1;				/* increment to next volume   * /
      vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX;		/* update volume indexes * /
      vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX;
      call move (fd.vlX, fd.sequence, code);
/*  NEW  */
      if code ^= 0
      then go to data_eot_fail;

      return;

/*  NEW  * /
write_EOV1:
   procedure (ecode);

dcl   ecode		        fixed bin (35);
dcl   t4			        picture "9999",
      t6			        picture "999999";	/* write the end_of_volume trail
						   2 tape marks an EOV1 label and then another tape mark    * /

      call write_TM (2, ecode);
      if ecode ^= 0
      then if ecode ^= error_table_$eov_on_write
	 then return;

      fd.dummy_blkcnt = cseg.blkcnt;			/* set up the end of volume label * /
      fd.eox = 2;					/* much of the label is not important * /
						/* the header and the volume id are distinctive * /
      if debug
      then call debug_print ("write_EOV");

      ibm_hdr1P = addr (lbl_buf);
      ibm_hdr1.label_id = "EOV1";
      ibm_hdr1.dataset_id = fd.file_id;
      ibm_hdr1.dataset_serial = fd.set_id;
      t4 = fd.flX;
      ibm_hdr1.volume_sequence = t4;
      t4 = fd.sequence;
      ibm_hdr1.dataset_sequence = t4;
      ibm_hdr1.generation = "";
      ibm_hdr1.version = "";
      ibm_hdr1.creation = " " || fd.creation;
      ibm_hdr1.expiration = " " || fd.expiration;
      ibm_hdr1.security = fd.access;
      t6 = cseg.lrec.blkcnt;
      ibm_hdr1.blkcnt = t6;
      ibm_hdr1.system = fd.system;
      ibm_hdr1.reserved = "";

      if cseg.standard = 1
      then sync_buf = cseg.lbl_buf;			/* ascii buffer for label  * /
      else call ascii_to_ebcdic_ (cseg.lbl_buf, sync_buf);	/* ebcidic convert and write * /


      call tape_ansi_tape_io_$sync_write (cP, 80, ecode);	/*   write it  * /

      if ecode ^= 0
      then if ecode ^= error_table_$eov_on_write
	 then return;

      call write_TM (1, ecode);			/* last tape mark written after label * /

      return;					/* with error ecode = 0 eot or error  * /


   end write_EOV1;

/*  NEW  */
close:
   entry (iocbP, code);				/* iox_$close entry */

      cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr;
						/* get control segment pointer */

      if cseg.file_lock
      then
         do;					/* file in use? */
	  code = error_table_$file_busy;
	  return;
         end;
      else
         do;
	  on cleanup cseg.file_lock = "0"b;
	  cseg.file_lock = "1"b;
         end;

      if cseg.invalid
      then
         do;
	  code = error_table_$invalid_cseg;
	  on cleanup go to close_exit1;
	  go to close_exit1;
         end;

      if cseg.open_mode = 4
      then
         do;					/* input mode */
	  cc = 0;					/* minimal consistency requirement */
	  on cleanup go to close_fail;
	  call tape_ansi_ibm_lrec_io_$close (cP, code);
	  if code ^= 0
	  then call consistent;
	  go to close_exit;
         end;

      else
         do;					/* output mode */
	  cc = 2;					/* don't leave defective tape file */
	  on cleanup go to close_fail;
	  call tape_ansi_ibm_lrec_io_$close (cP, code);
	  if code ^= 0
	  then
	     do;					/* maybe trouble */
	        if code ^= error_table_$eov_on_write
	        then
		 do;				/* EOT is ok */
close_fail:
		    call consistent;
		    go to close_exit;
		 end;
	     end;

/*  OLD  */
	  call write_TM (2, code);			/* write trailer and end-of-volume TMs */
						/*  OLD  */
						/*  NEW  * /
	  if cseg.blkcnt = 0
	  then
	     do;					/* if no blocks written empty file * /
	        vl (fd.vlX).lflX = vl (fd.vlX).cflX - 1;	/* set the last position and issue error * /
	        code = error_table_$empty_file;
	     end;

	  else vl (fd.vlX).lflX = vl (fd.vlX).cflX;	/* update the volume indexes after a write * /

	  call write_TM (3, code);			/* write trailer and the 2 end-of-volume TMs * /
/*  NEW  */
	  if code ^= 0
	  then
	     do;
	        if code = error_table_$eov_on_write
	        then code = 0;
	        else go to close_fail;
	     end;
	  cc = 0;

         end;

close_exit:
      if cseg.close_rewind
      then
         do;					/* rewind volume at close time */
	  vl (fd.vlX).cflX = 0;			/* invalidate volume position */
	  call tape_ansi_tape_io_$order (cP, "rew", 0, 0);/* issue the order */
	  cseg.close_rewind = "0"b;			/* this is a one time switch */
         end;
close_exit1:
      mask = "0"b;
      revert cleanup;
      on any_other call handler;
      call hcs_$set_ips_mask ("0"b, mask);
      iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_nl_file_cntl_$open;
      iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_;
      iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null;
      call iox_$propagate (iocbP -> iocb.actual_iocb_ptr);
      call hcs_$reset_ips_mask (mask, mask);
      cseg.file_lock = "0"b;
      return;

debug_on:
   entry;						/* turns debug switch on */
      debug = "1"b;
      return;

debug_off:
   entry;						/* truns debug switch off */
      debug = "0"b;
      return;

debug_print:
   procedure (text);				/* prints debug text */
dcl   text		        char (*);

      call ioa_ (text);
      return;

   end debug_print;


   end tape_ansi_nl_file_cntl_;




		    tape_ansi_parse_options_.pl1    09/24/86  1501.3rew 09/24/86  1453.0      133758



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




/****^  HISTORY COMMENTS:
  1) change(86-08-18,GWMay), approve(), audit(), install():
     old history comments:
     Modified 9/79 by R.J.C. Kissel to handle 6250 bpi tapes.
     Modified 2/82 by Chris Jones to add speed specification
     Modified 4/82 by J. A. Bush to allow blocksizes > 8192 bytes
  2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-15,Dupuis),
     install(86-09-24,MR12.0-1162):
     Changed to accommodate error message lengths > 32 chars.
                                                   END HISTORY COMMENTS */


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tape_ansi_parse_options_:
     procedure (taoP, options, error, code);

/* parameters */
dcl      options		  (*) char (*) varying,	/* attachment option array */
         error		  char (*) varying,		/* invalid option */
         code		  fixed bin (35);		/* error code */

%include tape_attach_options;

%include rcp_resource_types;


/* based storage */
dcl      opt		  char (nc_opt) based (optP); /* adjustable string for (*) varying -> (*) conversion */

/* automatic storage */
dcl      (i, j, k, temp)	  fixed bin,
         hyphen_ok		  bit (1),		/* volume name can begin with "-" switch */
         clock		  fixed bin (71),
         nc_opt		  fixed bin,		/* number of characters in opt string */
         optP		  ptr,			/* pointer to 1st char of (*) varying char string */
         temp21		  fixed bin (21),
         vn		  char (32),
         yy		  picture "99",
         ddd		  picture "999";

/* internal static storage */
dcl      1 key		  internal static,		/* option keywords */
	 2 n		  fixed bin init (23),	/* number of keywords */
	 2 long		  (23) char (16) varying
			  init
			  /* long forms */ ("-name", "-number", "-ring", "-extend", "-modify", "-generate",
			  "-create", "-format", "-block", "-record", "-mode", "-expires", "-user_labels",
			  "-density", "-track", "-device", "-retain", "-force", "-replace", "-dos", "-no_labels",
			  "-clear", "-speed"),
	 2 short		  (23) char (4) varying
			  init ("-nm", "-nb", "-rg", "-ext", "-mod", "-gen", "-cr", "-fmt", "-bk", "-rec", "-md",
			  "-exp", "-ul", "-den", "-trk", "-dv", "-ret", "-fc", "-rpl", "", "-nlb", "-cl", "-ips");

dcl      1 density		  internal static,		/* -density interpretation */
	 2 n		  fixed bin init (5),	/* number of possibilities */
	 2 type		  (5) char (4) varying init /* possibilities */ ("200", "556", "800", "1600", "6250"),
	 2 code		  (5) fixed bin init /* interpretation */ (0, 1, 2, 3, 4);

dcl      1 mode		  internal static,		/* -mode interpretation */
	 2 n		  fixed bin init (3),	/* number of possibilities */
	 2 type		  (3) char (8) varying init /* possibilities */ ("ascii", "ebcdic", "binary"),
	 2 code		  (3) fixed bin init /* interpretation */ (1, 2, 3);

dcl      1 retain		  internal static,		/* -retain interpretation */
	 2 n		  fixed bin init (4),	/* number of possibilities */
	 2 type		  (4) char (8) varying init /* possibilities */ ("none", "device", "volume", "all"),
	 2 code		  (4) fixed bin init /* interpretation */ (1, 2, 3, 4);

/* builtin functions */
dcl      (addr, dimension, fixed, index, length, rtrim, substr)
			  builtin;

/* external static */
dcl      sys_info$max_seg_size  fixed bin (35) external static;

/* error codes */
dcl      (
         error_table_$bad_arg,
         error_table_$bad_tapeid,
         error_table_$badopt,
         error_table_$noarg,
         error_table_$nodescr,
         error_table_$inconsistent
         )		  fixed bin (35) ext static;

/* external procedures */
dcl      convert_date_to_binary_
			  ext entry (char (*), fixed bin (71), fixed bin (35)),
         resource_info_$canonicalize_name
			  entry (char (*), char (*), char (*), fixed bin (35)),
         cv_dec_check_	  ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
         datebin_		  ext
			  entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin,
			  fixed bin, fixed bin, fixed bin),
         datebin_$dayr_clk	  ext entry (fixed bin (71), fixed bin);

	error = "";				/* initialize error message */
	code = 0;					/* initialize return code */

	tao.noptions = dimension (options, 1);		/* get number of array entries */
	if tao.noptions = 0 then do;			/* there must be at least a reel number */
	     code = error_table_$noarg;
	     return;
	end;

	hyphen_ok = "0"b;				/* initialize hyphen switch */
	i = 1;					/* begin with 1st option */
vol_loop:
	if options (i) = "-volume" then
	     go to vol_op;				/* option is -volume */
	if options (i) = "-vol" then do;		/* option is -vol */
vol_op:
	     hyphen_ok = "1"b;			/* next option may begin with "-" */
	     if no_next () then
		return;				/* no volume name follows */
	end;

	if substr (options (i), 1, 1) = "-" then do;	/* option begins with "-" */
	     if hyphen_ok then
		hyphen_ok = "0"b;			/* allowed - reset ok switch */
	     else do;				/* not allowed */
		if i = 1 then do;			/* must be at least 1 volume name */
bad_volname:
		     error = options (i);
		     code = error_table_$bad_tapeid;
		     return;
		end;
		go to normal_options;		/* this and remainder are control options */
	     end;
	end;
	else hyphen_ok = "0"b;			/* in case vol name doesn't begin with "-" */

	call resource_info_$canonicalize_name (VOLUME_TYPE (TAPE_VOL_VTYPEX), (options (i)), vn, code);
	if code ^= 0 then
	     goto bad_volname;
	options (i) = rtrim (vn);

	if tao.nvolumes = tao_max_volnames then do;	/* too many */
	     error = "Volume limit of 63 exceeded.";
	     code = error_table_$bad_arg;
	     return;
	end;
	tao.nvolumes = tao.nvolumes + 1;		/* increment volume count */
	tao.volname (tao.nvolumes) = vn;		/* save the volume name */
	i = i + 1;				/* increment to next option */
	if i > tao.noptions then
	     return;				/* exit when done */

	if options (i) = "-comment" then
	     go to com_op;				/* options is "-comment" */
	if options (i) = "-com" then do;		/* option is "-com" */
com_op:
	     if no_next () then
		return;				/* no comment string */
	     if length (options (i)) > 64 then
		go to bad2;			/* too long */
	     tao.comment (tao.nvolumes) = options (i);	/* save the comment */
	     i = i + 1;				/* increment to next option */
	     if i > tao.noptions then
		return;				/* done */
	end;

	go to vol_loop;				/* continue processing */

normal_options:
	do while (i <= tao.noptions);			/* and continue as long as options remain */

test:
	     do j = 1 to key.n;			/* test each keyword */
		if options (i) = key.long (j) then
		     go to match (j);		/* process when matched */
		if options (i) = key.short (j) then
		     go to match (j);		/* ditto */
	     end;
	     error = options (i);
	     code = error_table_$badopt;
	     return;


match (1):					/* -name */
	     if no_next () then
		return;				/* no fileid */
	     if length (options (i)) > 17 then
		go to bad2;			/* bad fileid */
	     tao.file_id = options (i);
	     go to next;

match (2):					/* -number */
	     if no_next () then
		return;				/* no sequence number */
	     optP = addr (substr (options (i), 1));
	     nc_opt = length (options (i));
	     temp = fixed (cv_dec_check_ (opt, code), 17);/* convert to binary */
	     if code ^= 0 then
		go to bad2;			/* bad fileseq */
	     if temp < 1 then
		go to bad2;
	     if temp > 9999 then
		go to bad2;
	     tao.sequence = temp;			/* ok */
	     go to next;


match (3):					/* -ring */
	     tao.write_ring = "1"b;
	     go to next;


match (4):					/* -extend */
	     if tao.output_mode ^= 0 then do;		/* previous mode */
mult_mode:
		error = long (j) || " and " || long (output_mode + 3);
		code = error_table_$inconsistent;
		return;
	     end;
	     tao.output_mode = 1;
	     tao.write_ring = "1"b;
	     go to next;

match (5):					/* -modify */
	     if tao.output_mode ^= 0 then
		go to mult_mode;
	     tao.output_mode = 2;
	     tao.write_ring = "1"b;
	     go to next;

match (6):					/* -generate */
	     if tao.output_mode ^= 0 then
		go to mult_mode;
	     tao.output_mode = 3;
	     tao.write_ring = "1"b;
	     go to next;


match (7):					/* -create */
	     if tao.output_mode ^= 0 then
		go to mult_mode;
	     tao.output_mode = 4;
	     tao.write_ring = "1"b;
	     go to next;


match (8):					/* -format */
	     if no_next () then
		return;				/* no format */
	     tao.format = options (i);		/* save it */
	     go to next;


match (9):					/* -block */
	     if no_next () then
		return;				/* no block length */
	     optP = addr (substr (options (i), 1));
	     nc_opt = length (options (i));
	     temp = fixed (cv_dec_check_ (opt, code), 17);
	     if code ^= 0 then
		go to bad2;
	     if temp < 18 then
		go to bad2;
	     tao.blklen = temp;			/* ok */
	     go to next;

match (10):					/* -record */
	     if no_next () then
		return;				/* no record length */
	     optP = addr (substr (options (i), 1));
	     nc_opt = length (options (i));
	     temp21 = fixed (cv_dec_check_ (opt, code), 21);
	     if code ^= 0 then
		go to bad2;
	     if temp21 < 1 then
		go to bad2;
	     if temp21 > sys_info$max_seg_size * 4 then
		go to bad2;
	     tao.reclen = temp21;			/* ok */
	     go to next;


match (11):					/* -mode */
	     if no_next () then
		return;				/* no recording mode */
	     do k = 1 to mode.n;			/* validate */
		if options (i) = mode.type (k) then do; /* match? */
		     tao.mode = mode.code (k);
		     go to next;
		end;
	     end;
	     go to bad2;				/* no match */

match (12):					/* -expires */
	     if no_next () then
		return;				/* no date */
	     optP = addr (substr (options (i), 1));
	     nc_opt = length (options (i));
	     call convert_date_to_binary_ (opt, clock, code);
						/* convert date */
	     if code ^= 0 then
		go to bad2;
	     call datebin_$dayr_clk (clock, j);		/* get day of year */
	     call datebin_ (clock, 0, 0, 0, k, 0, 0, 0, 0, 0);
						/* get year */
	     ddd = j;				/* convert to characters */
	     yy = k - 1900;
	     tao.expiration = yy || ddd;		/* form Julian date */
	     go to next;


match (13):					/* -user_labels */
	     if tao.no_labels then do;		/* -user_labels and -no_labels */
lbl_error:
		error = """-no_labels"" and ""-user_labels"".";
		code = error_table_$inconsistent;
		return;
	     end;
	     tao.user_labels = "1"b;
	     go to next;


match (14):					/* -density */
	     if no_next () then
		return;				/* no density */
	     do k = 1 to density.n;			/* validate */
		if options (i) = density.type (k) then do;
						/* match? */
		     tao.density = density.code (k);
		     go to next;
		end;
	     end;
	     go to bad2;				/* no match */


match (15):					/* -track */
	     if no_next () then
		return;				/* no track specification */
	     if options (i) = "7" then
		tao.ntracks = 7;
	     else if options (i) = "9" then
		tao.ntracks = 9;
	     else go to bad2;			/* bad track */
	     go to next;

match (16):					/* -device */
	     if no_next () then
		return;				/* no number of devices */
	     optP = addr (substr (options (i), 1));
	     nc_opt = length (options (i));
	     temp = fixed (cv_dec_check_ (opt, code), 17);/* convert ndevices */
	     if code ^= 0 then
		go to bad2;			/* bad ndevices */
	     if temp < 1 then
		go to bad2;
	     if temp > 63 then
		go to bad2;
	     tao.ndrives = temp;			/* ok */
	     go to next;

match (17):					/* -retain */
	     if no_next () then
		return;				/* no retention option */
	     do k = 1 to retain.n;			/* test each valid retain */
		if options (i) = retain.type (k) then do;
						/* match */
		     tao.retain = retain.code (k);
		     go to next;
		end;
	     end;
	     go to bad2;				/* no match */


match (18):					/* -force */
	     tao.force = "1"b;			/* set force overwrite bit */
	     go to next;


match (19):					/* -replace */
	     if no_next () then
		return;				/* no file identifier */
	     if length (options (i)) > 17 then
		go to bad2;
	     tao.replace_id = options (i);
	     go to next;


match (20):					/* -dos */
	     tao.DOS = "1"b;
	     go to next;


match (21):					/* -no_labels */
	     if tao.user_labels then
		go to lbl_error;			/* conflict */
	     tao.no_labels = "1"b;
	     go to next;

match (22):
	     tao.clear_cseg = "1"b;			/* flag to delete present cseg */
	     goto next;

match (23):
	     begin;
dcl      COMMA		  char (1) init (",") static options (constant);
dcl      current_value	  char (32) varying;
dcl      current_idx	  fixed bin;		/* how far we've gotten into value */

		if no_next () then
		     return;
		current_idx = 1;			/* start from the beginning of the string */
		current_value = get_next_value ();
		if current_value = "" then
		     goto bad2;			/* insist on at least one */
		do while (current_value ^= "");
		     if current_value = "75" then
			tao.speed = tao.speed | "100"b;
		     else if current_value = "125" then
			tao.speed = tao.speed | "010"b;
		     else if current_value = "200" then
			tao.speed = tao.speed | "001"b;
		     else goto bad2;
		     current_value = get_next_value ();
		end;				/* do while ... */

get_next_value:
     proc returns (char (32) varying);

dcl      next_value		  char (32) varying;

	if current_idx = -1 then
	     return ("");
	if index (substr (options (i), current_idx), COMMA) = 0 then do;
	     next_value = substr (options (i), current_idx);
	     current_idx = -1;			/* so next call will stop */
	     return (next_value);
	end;
	else do;
	     next_value = substr (options (i), current_idx, index (substr (options (i), current_idx), COMMA) - 1);
	     current_idx = current_idx + length (next_value) + 1;
	     return (next_value);
	end;

     end get_next_value;

	     end;					/* the begin */
	     goto next;

next:
	     i = i + 1;				/* get next keyword */
	end;
	return;					/* done */

bad2:
	error = options (i - 1) || " " || options (i);	/* form string */
	code = error_table_$bad_arg;
	return;

no_next:
     procedure returns (bit (1));			/* sees if 2nd part of two-part option exists */
	if i + 1 > tao.noptions then do;		/* does 2nd part exist? */
	     error = options (i);			/* no - get keyword */
	     code = error_table_$nodescr;
	     return ("1"b);
	end;
	else do;					/* 2nd part does exist */
	     i = i + 1;				/* increment the option index */
	     return ("0"b);
	end;
     end no_next;


     end tape_ansi_parse_options_;




		    tape_ansi_position_.pl1         11/04/82  1931.3rew 11/04/82  1606.1       44136



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





tape_ansi_position_: procedure (iocbP, type, n, code);	/* iox_$position entry for tape_ansi_ IO Module */


%include iocb;

%include tape_ansi_cseg;


/* arguments */
dcl  iocbP ptr,					/* pointer to iocb */
     type fixed bin,				/* -1 : position to beginning of file */
						/*  0 : position +_ n records (only +n supported) */
						/* +1 : position to end of file */
     n fixed bin (21),				/* number of records : type = 0 */
     code fixed bin (35);				/* returned error code */

/* automatic */
dcl (i, j) fixed bin (21),				/* temporary storage */
     tape_error bit (1) aligned;			/* parity error switch */

/* external procedures */
dcl  tape_ansi_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     tape_ansi_file_cntl_$beginning_of_file ext entry (ptr, fixed bin (35)),
     tape_ansi_file_cntl_$end_of_file ext entry (ptr, fixed bin (35)),
     tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     tape_ansi_nl_file_cntl_$beginning_of_file ext entry (ptr, fixed bin (35)),
     tape_ansi_nl_file_cntl_$end_of_file ext entry (ptr, fixed bin (35));

/* external static */
dcl (error_table_$bad_arg,
     error_table_$fatal_error,
     error_table_$file_busy,
     error_table_$long_record,
     error_table_$tape_error,
     error_table_$invalid_cseg) fixed bin (35) ext static;

/* builtin functions */
dcl  null builtin;

/* conditions */
dcl  cleanup condition;

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* set pointer to control segment */

	if cseg.invalid then do;
	     code = error_table_$invalid_cseg;
	     return;
	end;

	if cseg.file_lock then do;			/* is file in use? */
	     code = error_table_$file_busy;
	     return;
	end;
	else do;
	     on cleanup begin;
		cseg.code = error_table_$fatal_error;
		cseg.file_lock = "0"b;
	     end;
	     cseg.file_lock = "1"b;
	end;

	if type < -1 | type > 1 then do;		/* invalid type */
	     code = error_table_$bad_arg;
	     go to exit;
	end;
	else go to action (type);			/* perform appropriate positioning operation */

action (-1):					/* position to beginning of file */

	if cseg.no_labels then call tape_ansi_nl_file_cntl_$beginning_of_file (iocbP, code);
	else call tape_ansi_file_cntl_$beginning_of_file (iocbP, code); /* move to 1st data record */
	if code ^= 0 then cseg.code = code;		/* disallow subsequent read ops */
	go to exit;


action (+1):					/* position to end of file */

	if cseg.no_labels then call tape_ansi_nl_file_cntl_$end_of_file (iocbP, code);
	else call tape_ansi_file_cntl_$end_of_file (iocbP, code); /* move to data EOF */
	if code ^= 0 then cseg.code = code;		/* disallow subsequent read ops */
	go to exit;

action (0):					/* position forward (n > 0) */

	code = 0;					/* initialize return code */
	tape_error = "0"b;				/* initialize parity error switch */

	if n = 0 then go to exit;			/* nothing to do */
	if n < 0 then do;				/* positioning backwards isn't supported */
	     code = error_table_$bad_arg;
	     go to exit;
	end;

	i = n;					/* copy n */

	if cseg.rlN ^= -1 then do;			/* next record is in read length segment */
	     cseg.rlN = -1;				/* that record has just been position over */
	     i = i - 1;				/* decrement count */
	end;

	do j = 1 to i;				/* skip records until done or error or end of file */
	     cseg.file_lock = "0"b;			/* unlock so lrec_io_ call will work */
	     if cseg.standard = 1 then call tape_ansi_lrec_io_$read_record (iocbP, null, 0, 0, code);
	     else call tape_ansi_ibm_lrec_io_$read_record (iocbP, null, 0, 0, code);
	     if code = error_table_$long_record then code = 0; /* ignore this */
	     else if code = 0 then;			/* rare, only skipping a zero-length record */
	     else if code = error_table_$tape_error then do; /* ignore for now, but remember */
		tape_error = "1"b;			/* this does the remembering */
		cseg.code = 0;			/* this allows further lrec_io_ calls */
	     end;
	     else go to exit;			/* fatal error or EOF - give up */
	     cseg.file_lock = "1"b;			/* relock to avoid unlikely but disasterous situation */
	end;

	if tape_error then do;			/* a parity error occurred */
	     cseg.code = error_table_$tape_error;	/* inhibit further I/O */
	     code = error_table_$tape_error;		/* set return code */
	end;

exit:	cseg.file_lock = "0"b;
	return;



     end tape_ansi_position_;




		    tape_ansi_read_length_.pl1      11/04/82  1931.3rew 11/04/82  1606.1       34974



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





tape_ansi_read_length_: procedure (iocbP, reclen, code);	/* iox_$read_length entry for tape_ansi_ IO Module */


%include iocb;

%include tape_ansi_cseg;


/* arguments */
dcl  iocbP ptr,					/* pointer to iocb */
     reclen fixed bin (21),				/* returned record length */

     code fixed bin (35);				/* returned error code */

/* external procedures */
dcl  tape_ansi_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)),
     hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
     tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));

/* external static */
dcl  sys_info$max_seg_size fixed bin (35) external static;

/* error codes */
dcl (error_table_$fatal_error, error_table_$file_busy, error_table_$tape_error, error_table_$invalid_cseg) fixed bin (35) external static;

/* internal static */
dcl  nc_wanted fixed bin (21) internal static;		/* maximum record length */

/* builtin functions */
dcl (null, prec, substr) builtin;

/* conditions */
dcl  cleanup condition;

	cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* set pointer to control segment */

	if cseg.invalid then do;			/* is control segment invalid? */
	     code = error_table_$invalid_cseg;
	     return;
	end;

	if cseg.file_lock then do;			/* is file in use? */
	     code = error_table_$file_busy;
	     return;
	end;
	else do;
	     on cleanup begin;
		cseg.file_lock = "0"b;
		cseg.code = error_table_$fatal_error;
	     end;
	     cseg.file_lock = "1"b;
	end;

	if cseg.rlP = null then do;			/* read length segment not known */
	     call hcs_$make_seg ("", cseg.module || vl (1).volname || "_.rl", "", 01011b, cseg.rlP, code);
	     if cseg.rlP = null then do;		/* shouldn't be - serious trouble */
		cseg.code = error_table_$fatal_error;
		go to exit;
	     end;
	     else do;				/* all is well */
		nc_wanted = prec (sys_info$max_seg_size * 4, 21); /* compute maximum record length */
		go to none;			/* nothing in segment - fill it */
	     end;
	end;

	if cseg.rlN = -1 then do;			/* get a record if none in read length segment */
none:	     cseg.file_lock = "0"b;			/* unlock so lrec_io_ call will work */
	     if cseg.standard = 1 then call tape_ansi_lrec_io_$read_record (iocbP, cseg.rlP, nc_wanted, cseg.rlN, code);
	     else call tape_ansi_ibm_lrec_io_$read_record (iocbP, cseg.rlP, nc_wanted, cseg.rlN, code);
	     cseg.file_lock = "1"b;			/* avoid conflicts */
	     if code = 0 | code = error_table_$tape_error then /* record hasn't been read */
		cseg.lrec.reccnt = cseg.lrec.reccnt - 1; /* yet by the user */
	     else do;				/* error or event */
		reclen = 0;			/* return 0 record length */
		cseg.rlN = -1;			/* insure cseg.rlN -> empty */
		go to exit;			/* cseg.lrec.reccnt wasn't incremented */
	     end;
	end;
	else code = 0;				/* no lrec_io_ call, so 0 error code */

	reclen = cseg.rlN;				/* return record length; from actual lrec_io_ call... */
						/* or, from previous read length operation            */
						/* note that read_length does _n_o_t change position     */
						/* so that multiple read_length calls without inter-  */
						/* vening read_record or position calls all refer to  */
						/* the same record.				    */
exit:	cseg.file_lock = "0"b;
	return;

     end tape_ansi_read_length_;




		    tape_ansi_tape_io_.pl1          09/24/86  1501.3rew 09/24/86  1453.1      305190



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




/****^  HISTORY COMMENTS:
  1) change(86-08-18,GWMay), approve(), audit(), install():
     old history comments:
     Modified 9/79 by R.J.C. Kissel to handle 6250 bpi tapes
     Modified 4/82 by J. A. Bush for block sizes > 8192 Bytes
  2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-17,Dupuis),
     install(86-09-24,MR12.0-1162):
     Changed to look up the wait switch for a given drive using the cseg.vl
     entry.
                                                   END HISTORY COMMENTS */


/* format: style3,ind3,dclind6,idind32 */
tape_ansi_tape_io_:
   proc;

%include tape_ansi_cseg;

dcl   (bP, CP)		        ptr,		/* parameters */
      ccount		        fixed bin,		/* character count argument */
      code		        fixed bin (35),	/* returned error code */
      operation		        char (3);		/* order code */

dcl   (
      error_table_$tape_error,			/* error codes returned */
      error_table_$nine_mode_parity,
      error_table_$blank_tape,
      error_table_$eov_on_write,
      error_table_$positioned_on_bot,
      error_table_$eof_record,
      error_table_$fatal_error,
      tape_status_$ready_at_bot,			/* error codes referenced */
      tape_status_$subsystem_ready,
      tape_status_$device_data_alert,
      tape_status_$end_of_tape,
      tape_status_$end_of_file,
      tape_status_$command_reject,
      tape_status_$mpc_device_data_alert,
      tape_status_$blank_tape_on_read,
      tape_status_$reject_at_bot
      )			        fixed bin (35) ext;

dcl   (addr, bin, divide, fixed, index, lbound, null, rel)
			        builtin;


dcl   ecode		        fixed bin (35) init (0),
						/* automatic storage */
      (synchro, loop_bit, reset_wait) bit (1),		/* internal logic switches */
      (i, indx, errc)	        fixed bin;		/* temporary storage */
dcl   drive_number		        fixed bin;		/* Set by setup. */

dcl   (
      tmodes		        (0:1) fixed bin (2) initial (0, 2),
						/* internal static variables */
      oplist		        (17) bit (6) aligned
			        initial ("47"b3, "46"b3, "54"b3, "45"b3, "44"b3, "00"b3, "40"b3, "70"b3, "72"b3,
			        "55"b3, "62"b3, "63"b3, "64"b3, "61"b3, "60"b3, "65"b3, "41"b3),
						/* decimal orders */
      codechart		        char (52) initial ("bsf bsr ers fsf fsr rqs rss rew run eof pro per sdn")
      )			        internal static;

dcl   1 internal_codes	        based (addr (oplist)),
        2 (bsf, bsr, ers, fsf, fsr, rqs, rss, rew, run, eof, pro, per, s200, s556, s800, s1600, s6250)
			        bit (6) aligned;

dcl   tdcm_$tdcm_iocall	        ext entry (ptr, fixed bin (35)),
      tdcm_$tdcm_set_signal	        ext entry (ptr, fixed bin (35)),
      tdcm_$tdcm_reset_signal	        ext entry (ptr, fixed bin (35)),
      tape_ansi_interpret_status_     ext entry (ptr),
      ipc_$block		        ext entry (ptr, ptr, fixed bin (35));

attach:
   entry (CP);					/* attach entry - initializes tseg */
      cP = CP;					/* copy pointer to cseg */
      cseg.syncP = addr (tseg.buffer (4));
      tseg.mode (4) = 2;				/* always 9 mode for synchronous (label) buffer */
      do i = 1 to 4;				/* set tseg buffer pointers */
         tseg.bufferptr (i) = fixed (rel (addr (tseg.buffer (i))));
      end;
      cseg.wait_switch (*) = "0"b;			/* not waiting for any wakeups */
      return;

open:
   entry (CP);					/* open entry - initialize buffer management */
      cP = CP;
      free_list = 1;				/* initialize buffer indices */
      busy_list = 0;
      chain (1) = 2;				/* initialize free chain */
      chain (2) = 3;
      chain (3) = 0;
      soft_status.nbuf = 0;				/* initialize software status */
      do i = 1 to 3;				/* initialize IO buffer modes */
         tseg.mode (i) = tmodes (cseg.mode);
      end;
      return;


/*  This entry can return one of two codes:                      */
/*                                                                 */
/*  1) 0 - normal                                                  */
/*  2) error_table_$fatal_error - processing cannot continue     */
/*  Note that EOT on a write synchronize is suppressed.            */

synchronize:
close:
   entry (CP, code);				/* synchronize entry - synchronize read/write */
      call setup;
      if code ^= 0
      then return;
      tseg.sync = 1;
      if tseg.write_sw ^= 1
      then
         do;					/* check for read synchronization */
	  if busy_list ^= 0
	  then
	     do;					/* if any buffers */
	        tseg.command_count = 1;		/* must backspace one record */
	        tseg.buffer_count = 0;		/* no buffers involved */
	        tseg.command_queue (1) = bin (bsr);	/* set backspace record code */
retry:
	        call tdcm_$tdcm_iocall (addr (tseg), ecode);
						/* do backspace */
	        if ecode ^= 0
	        then
		 do;				/* error calling tdcm */
		    code = error_table_$fatal_error;
		    return;
		 end;
	        if tseg.completion_status ^= 1
	        then
		 do;				/* something unusual happened */
		    if tseg.command_count = 1
		    then go to retry;		/* previous read erroneous - retry bsr */
		    hdw_status.bits = tseg.hardware_status || (36)"0"b;
						/* pad to 72 bits */
		    call tape_ansi_interpret_status_ (addr (hdw_status));
						/* see what happened */
		    if hdw_status.major ^= tape_status_$end_of_file
		    then
		       do;			/* error if ^ EOF */
			code = error_table_$fatal_error;
						/* set error code */
			return;			/* exit */
		       end;
		 end;
	        if free_list ^= 0
	        then chain (busy_list) = free_list;
	        free_list = busy_list;
	        busy_list = 0;
	     end;
	  return;
         end;

      if busy_list = 0
      then return;					/* write case */
      synchro = "1"b;
      tseg.command_count, tseg.buffer_count = 0;		/* set tseg */
      indx = busy_list;
      errc = 10;
      loop_bit = "0"b;
      go to synch_write;				/* join write code at iocall */


/*  This entry returns one of two error codes:             */
/*  1) 0 - normal                                            */
/*  2) error_table_$fatal_error                              */

get_buffer:
   entry (CP, bP, code);				/* get_buffer entry - sets pointer to io_buffer */
      cP = CP;					/* copy pointer */
      bP = null;					/* null buffer pointer */
      code = 0;					/* and zero rc */
findfree:
      if free_list ^= 0
      then
         do;					/* if there is a free bufer hand it to him */
	  indx = free_list;				/* set index to free buffer */
	  free_list = chain (indx);			/* and take it off free chain */
	  chain (indx) = 0;				/* no successor */
	  bP = addr (tseg.buffer (indx));		/* return address to buffer */
	  return;
         end;
      if busy_list = 0
      then
         do;					/* check for all buffers allocated */
	  code = error_table_$fatal_error;
	  return;
         end;
      call synchronize (cP, code);			/* synchrionize the tape */
      if code ^= 0
      then return;					/* give up if error */
      go to findfree;				/* check for buffer again */


/*  This entry returns either 0 or error_table_$fatal_error  */

release_buffer:
   entry (CP, bP, code);				/* release_buffer entry - returns buffer to free pool */
      cP = CP;					/* copy pointer */
      code = 0;
      do indx = 1 to 3;				/* search for buffer pointer match */
         if bP = addr (cseg.buffer (indx))
         then go to gotbuf;				/* look for match */
      end;
      code = error_table_$fatal_error;			/* no match found, return error code */
      return;
gotbuf:
      chain (indx) = free_list;			/* put onto beginning of free list chain */
      free_list = indx;
      bP = null;					/* null out pointer */
      return;


/*  This entry returns one of five error codes:                         */
/*  1) 0 - normal                                                       */
/*  2) error_table_$eof_record  -  read end of file mark                */
/*  3) error_table_$blank_tape  -  read blank tape, bad volume format   */
/*  4) error_table_$tape_error - parity-type tape error               */
/*  5) error_table_$fatal_error - cannot continue processing            */
/*  Note that with tape_error, ccount and bP are valid		   */

read:
   entry (CP, bP, ccount, code);			/* returns one block */
      bP = null;					/* initialize in case of error */
      ccount = 0;					/* ditto */
      call setup;					/* initialize */
      if code ^= 0
      then return;					/* trouble with rewind wait */

read_ahead:
      if free_list = 0
      then
         do;					/* check for free buffer */
	  if busy_list ^= 0
	  then
	     do;					/* check for busy buffer  */
	        errc = 25;				/* can't read ahead. initialize error retry count */
	        tseg.command_count, tseg.buffer_count = 0;/* clear (tdcm will just wait) */
	        go to await_tape;			/* call tdcm to wait or tape */
	     end;					/* end of code for locked buffer */
	  code = error_table_$fatal_error;		/* there are just no buffers left */
	  return;					/* so return to the buffer hog with an error */
         end;					/* end of code for no free buffer */
      indx = free_list;				/* set index into first free buffer */
      free_list = chain (indx);			/* reset free list start */
      chain (indx) = 0;
      if busy_list = 0
      then busy_list = indx;
      else chain (busy_list) = indx;
      tseg.sync = 0;				/* read asynchronously */
      errc = 25;					/* initialize in case of error */

restart_read:
      tseg.buffer_offset = indx - 1;			/* set tseg buffer pointer */
      tseg.buffer_count = 1;				/* one buffer @ a time */
      tseg.command_count = 0;				/* indicate reading */
      tseg.write_sw = 0;				/* "" */
      tseg.buffer_size (indx) = divide (cseg.buf_size, 4, 18, 0);

await_tape:
      call tdcm_$tdcm_iocall (addr (tseg), ecode);	/* call tdcm to do io */
      if ecode ^= 0
      then go to r_fatal;				/* error in call is fatal */

      if tseg.completion_status = 0
      then go to read_ahead;				/* not complete - read another record while waiting */
      else bufct (busy_list) = tseg.buffer_size (busy_list);/* complete - set buffer size */

      hdw_status.bits = tseg.hardware_status || (36)"0"b;	/* set hardware_status string */

      if tseg.completion_status = 1
      then
         do;					/* read complete and valid */
	  hdw_status.major = tape_status_$subsystem_ready;/* return minimal status information */
	  hdw_status.no_minor = 0;			/* to avoid expense of interpretation call */
return_data:
	  bP = addr (cseg.buffer (busy_list));		/* return buffer pointer */
	  ccount = bufct (busy_list) * 4;		/* and buffer count */
	  busy_list = chain (busy_list);		/* unbusy buffer */
	  return;
         end;

      call tape_ansi_interpret_status_ (addr (hdw_status)); /* ERROR or EVENT - see what happened */

      if hdw_status.major = tape_status_$end_of_file
      then
         do;					/* EOF ? */
	  code = error_table_$eof_record;
	  go to r_exit;
         end;

      i = chain (busy_list);				/* error - free the last busied buffer */
      if i ^= 0
      then
         do;
	  chain (busy_list) = 0;
	  chain (i) = free_list;
	  free_list = i;
         end;
      indx = busy_list;

      if hdw_status.minor (1) = tape_status_$blank_tape_on_read
      then
         do;					/* give up */
	  code = error_table_$blank_tape;
	  go to r_exit;
         end;

      if hdw_status.major = tape_status_$device_data_alert
      then go to check_retry;				/* may be recoverable */
      if hdw_status.major = tape_status_$mpc_device_data_alert
      then
         do;					/* ditto */
check_retry:
	  if errc = 0
	  then
	     do;					/* retries exhausted? */
	        if bufct (busy_list) = 0
	        then go to r_fatal;			/* no data at all - not a parity-type error */
	        code = error_table_$tape_error;		/* data returned, albeit erroneously */
	        go to return_data;
	     end;
	  else
	     do;					/* retries not exhausted */
	        errc = errc - 1;			/* decrement retry count */
	        tseg.command_queue (1) = bin (bsr);	/* set backspace record order code */
	        tseg.command_count = 1;		/* one order code to execute */
	        tseg.buffer_count = 0;		/* no buffers to read */
	        tseg.sync = 1;			/* retries are synchronous */
	        call tdcm_$tdcm_iocall (addr (tseg), ecode);
						/* call tdcm to backspace tape */
	        if ecode ^= 0
	        then go to bsr_error;
	        if tseg.completion_status ^= 1
	        then
		 do;
bsr_error:
		    code = error_table_$fatal_error;
		    go to r_exit;
		 end;
	        go to restart_read;			/* restart the read operation */
	     end;
         end;

r_fatal:
      code = error_table_$fatal_error;

r_exit:
      if chain (busy_list) = 0
      then i = busy_list;				/* free the last busied buffer */
      else i = chain (busy_list);
      chain (i) = free_list;
      free_list = busy_list;
      busy_list = 0;
      return;


/*  This entry can return one of five error codes:                    */
/*  1) 0 - normal                                                     */
/*  2) error_table_$eof_record - read end of file mark                */
/*  3) error_table_$blank_tape - read blank tape, bad vol format     */
/*  4) error_table_$tape_error - unrecoverable tape error             */
/*  5) error_table_$fatal_error - cannot continue processing          */

sync_read:
   entry (CP, ccount, code);				/* entry to read 1 block using syncP buffer */
      ccount = 0;					/* initialize in case of error */
      call setup;					/* initialize */
      if code ^= 0
      then return;					/* trouble with rewind */
      call synchronize (cP, code);			/* synchronize IO */
      if code ^= 0
      then return;
      tseg.write_sw = 0;				/* set write off, we're reading */
      i = 1;					/* one order code for recovery */
      errc = 25;					/* set read retry count */
      go to sync_com;				/* join common erb code */


/*  This entry can return one of four error codes:                    */
/*  1) 0 - normal                                                     */
/*  2) error_table_$eov_on_write - EOT detected                       */
/*  3) error_table_$tape_error  -  unrecoverable tape error           */
/*  4) error_table_$fatal_error - cannot continue processing          */

sync_write:
   entry (CP, ccount, code);				/* entry to write a block using syncP buffer */
      call setup;					/* initialize */
      if code ^= 0
      then return;					/* trouble with rewind */
      call synchronize (cP, code);			/* synchronize IO */
      if code ^= 0
      then return;
      tseg.write_sw = 1;				/* set tseg write switch */
      i = 2;					/* 2 order codes for recovery */
      errc = 10;					/* set write retry count */
      tseg.command_queue (2) = bin (ers);		/* set bin (ers) code */


sync_com:
      tseg.sync = 1;				/* synchronous operation */
      tseg.command_queue (1) = bin (bsr);		/* set backspace record recovery op */
      tseg.buffer_offset = 3;				/* buffer 4 is the recovery buffer */

sync_restart:
      if i = 2
      then tseg.buffer_size (4) = ccount / 4;		/* set count for write */
      else tseg.buffer_size (4) = divide (cseg.buf_size, 4, 18, 0);
						/* read: try to get maximum */
      tseg.command_count = 0;				/* we are reading or writing */
      tseg.buffer_count = 1;				/* .... */
      call tdcm_$tdcm_iocall (addr (tseg), ecode);	/* do io */

      if ecode ^= 0
      then
         do;					/* error from tdcm */
sync_fatal:
	  code = error_table_$fatal_error;		/* set return code */
	  return;					/* exit */
         end;

      hdw_status.bits = tseg.hardware_status || (36)"0"b;	/* get and pad hardware status */
      call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */

      if tseg.completion_status ^= 1
      then
         do;					/* something untoward happened */
	  if hdw_status.major = tape_status_$end_of_file
	  then
	     do;					/* EOF detected */
	        if i = 1
	        then
		 do;				/* on a read */
		    code = error_table_$eof_record;	/* set return code */
		    go to sync_return;
		 end;
	        else go to sync_error;		/* just shouldn't happen when writing */
	     end;

	  if hdw_status.major = tape_status_$subsystem_ready
	  then
	     do;					/* but no major status */
	        code = error_table_$nine_mode_parity;	/* must be invalid 9 mode data */
	        hdw_status.major = code;
	        hdw_status.no_minor = 0;
	        return;
	     end;

	  if hdw_status.no_minor = 1
	  then
	     do;					/* simple cases */
	        if hdw_status.minor (1) = tape_status_$end_of_tape
	        then
		 do;				/* EOT detected */
		    if i = 1
		    then go to sync_error;		/* shouldn't happen on read */
		    code = error_table_$eov_on_write;
		    return;
		 end;
	        if hdw_status.minor (1) = tape_status_$blank_tape_on_read
	        then
		 do;				/* trouble */
		    if i = 2
		    then go to sync_error;		/* shouldn't happen on write */
		    code = error_table_$blank_tape;
		    return;
		 end;
	     end;

	  if hdw_status.major = tape_status_$device_data_alert
	  then go to sync_repos;			/* reposition */
	  if hdw_status.major = tape_status_$mpc_device_data_alert
	  then
	     do;					/* reposition */
sync_repos:
	        tseg.command_count = i;		/* set count */
	        tseg.buffer_count = 0;		/* and clear buffer count */
	        errc = errc - 1;			/* decrement retry count */
	        call tdcm_$tdcm_iocall (addr (tseg), ecode);
						/* have tdcm reposition */
	        if ecode ^= 0
	        then go to sync_fatal;		/* call to tdcm failed */
	        if tseg.completion_status = 2
	        then
		 do;				/* io failed */
		    hdw_status.bits = tseg.hardware_status || (36)"0"b;
						/* trouble - get status */
		    call tape_ansi_interpret_status_ (addr (hdw_status));
						/* interpret it */
		    if hdw_status.no_minor = 1
		    then
		       do;			/* simple case ? */
			if hdw_status.minor (1) = tape_status_$end_of_tape
			then go to sync_test;	/* EOT ok */
		       end;
		    go to sync_error;		/* give up */
		 end;
sync_test:
	        if errc >= 0
	        then go to sync_restart;		/* retry if count not exhausted */
	     end;					/* end of recovery loop */

sync_error:
	  code = error_table_$tape_error;		/* indicate trouble with tape */
	  return;					/* exit */
         end;

sync_return:
      if i = 1
      then ccount = 4 * tseg.buffer_size (4);		/* return count if read */
      return;					/* and return to caller */


/*  This entry returns one of four error codes:                    */
/*  1) 0 - normal                                                  */
/*  2) error_table_$eov_on_write - EOT detected                    */
/*  3) error_table_$tape_error - unrecoverable tape error          */
/*  4) error_table_$fatal_error - cannot continue processing       */

write:
   entry (CP, bP, ccount, code);			/* write entry - stacks one write */
      call setup;					/* initizlize */
      if code ^= 0
      then return;					/* trouble with rewind */
      synchro = "0"b;				/* set flag - this is not a synchronize operation */
      do indx = 1 to 3;				/* find buffer index */
         if bP = addr (cseg.buffer (indx))
         then go to gotbuf1;
      end;
      go to w_fatal;				/* invalid buffer */

gotbuf1:
      bufct (indx) = ccount / 4;			/* set count */
      if busy_list = 0
      then busy_list = indx;
      else chain (busy_list) = indx;
      chain (indx) = 0;
      tseg.buffer_size (indx) = bufct (indx);		/* set tseg buffer size */

rstrtw:
      if ^synchro
      then tseg.sync = 0;				/* write asynchronously if ^synchronize call */
      loop_bit = "0"b;				/* restart (or start) afresh */
      errc = 10;					/* initialize in case of error */

rtryw:
      tseg.write_sw = 1;
      tseg.buffer_offset = indx - 1;			/* set tseg buffer index */
      tseg.buffer_count = 1;				/* one buffer to deal with */
      tseg.command_count = 0;				/* no order codes */

synch_write:
      call tdcm_$tdcm_iocall (addr (tseg), ecode);	/* call tseg to write buffer */

      if ecode ^= 0
      then
         do;					/* call to tdcm failed */
w_fatal:
	  code = error_table_$fatal_error;		/* set error code */
	  return;					/* give up */
         end;

      if tseg.completion_status = 1
      then
         do;					/* check for write completed */
	  indx = chain (busy_list);
	  chain (busy_list) = free_list;
	  free_list = busy_list;
	  busy_list = indx;
         end;

      else if tseg.completion_status = 0
      then ;					/* operation not complete */

      else
         do;					/* error or event occurred */
	  hdw_status.bits = tseg.hardware_status || (36)"0"b;
						/* get hardware status and pad */
	  call tape_ansi_interpret_status_ (addr (hdw_status));
						/* interpret it */
	  if hdw_status.no_minor = 1
	  then
	     do;					/* simple case? */
	        if hdw_status.minor (1) = tape_status_$end_of_tape
	        then
		 do;				/* report it */
		    code = error_table_$eov_on_write;	/* set error code */
		    indx = chain (busy_list);		/* buffer _w_a_s written: get next in queue */
		    chain (busy_list) = free_list;	/* fill the queue slot */
		    free_list = busy_list;		/* the buffer written is now free */
		    busy_list = indx;		/* buffer pulled from queue is now busy */
		    if busy_list = 0
		    then go to synch_check;		/* queue was empty - exit */
		    tseg.sync = 1;			/* do this buffer synchronously */
		    go to synch_write;		/* write it */
		 end;
	     end;

	  if hdw_status.major = tape_status_$subsystem_ready
	  then
	     do;					/* but no major status */
	        code = error_table_$nine_mode_parity;	/* must be invalid 9 mode data */
	        hdw_status.major = code;
	        hdw_status.no_minor = 0;
	        go to w_error1;
	     end;

	  if hdw_status.major = tape_status_$device_data_alert
	  then go to reposit;			/* reposition */
	  if hdw_status.major = tape_status_$mpc_device_data_alert
	  then
	     do;					/* reposition */
reposit:
	        tseg.sync = 1;			/* retries synchronous */
	        loop_bit = "1"b;			/* indicate retrying */
	        errc = errc - 1;			/* decrement error retry count */
	        tseg.command_queue (1) = bin (bsr);	/* set backspace code */
	        tseg.command_queue (2) = bin (ers);	/* and erase code */
	        tseg.command_count = 2;		/* 2 commands to execute */
	        indx = busy_list;			/* retry first write */
	        tseg.buffer_count = 0;		/* reset buffer count */
	        call tdcm_$tdcm_iocall (addr (tseg), ecode);
						/* call tdcm to backspace and erase */
	        if ecode ^= 0
	        then go to w_fatal;			/* tdcm call failed - give up */
	        if tseg.completion_status = 2
	        then
		 do;				/* error occurred */
		    hdw_status.bits = tseg.hardware_status || (36)"0"b;
						/* trouble - get status */
		    call tape_ansi_interpret_status_ (addr (hdw_status));
						/* interpret it */
		    if hdw_status.no_minor = 1
		    then
		       do;			/* simple case? */
			if hdw_status.minor (1) = tape_status_$end_of_tape
			then go to w_test;		/* EOT is reasonable */
		       end;
		    go to w_error;			/* anything else is error */
		 end;
w_test:
	        if errc >= 0
	        then go to rtryw;			/* retry write if error count not exhausted */
	     end;

w_error:
	  code = error_table_$tape_error;
w_error1:
	  indx = busy_list;				/* report _a_l_l queued buffers */

w_report:
	  soft_status.nbuf = 0;			/* set suspended count */
	  do while (indx ^= 0);			/* set up suspended buffer list */
	     soft_status.nbuf = soft_status.nbuf + 1;
	     soft_status.bufP (nbuf) = addr (tseg.buffer (indx));
	     soft_status.count (nbuf) = bufct (indx) * 4; /* set buffer count */
	     indx = chain (indx);			/* and go to next buffer */
	  end;					/* end of code for setting up list of suspended buffers */
	  busy_list = 0;
	  go to synch_check;			/* return to caller */
         end;

      if loop_bit
      then if busy_list ^= 0
	 then
	    do;					/* see if more buffers (first in error) */
	       indx = busy_list;			/* index to suspended buffer */
	       go to rstrtw;			/* restart write */
	    end;					/* end of buffer error loop code */

synch_check:
      if ^synchro
      then bP = null;				/* write entry: null buffer pointer */
      else
         do;					/* synchronize/close entry */
	  if code = error_table_$eov_on_write
	  then code = 0;				/* ignore EOT */
	  else if code = error_table_$tape_error
	  then code = error_table_$fatal_error;		/* treat as fatal */
         end;
      return;					/* return to caller */


/*  The following codes may be returned:                             */
/*  1) 0 - all orders             			         */
/*  2) error_table_$fatal_error - all orders                         */
/*  3) error_table_$positioned_on_bot - bsf, bsr                     */
/*  4) error_table_$eov_on_write - ers, eof                          */
/*  5) error_table_$eof_record - fsr, bsr                            */
/*  6) error_table_$tape_error - all orders                          */

order:
   entry (CP, operation, ccount, code);			/* order entry - performs synchronous order calls */
      call setup;					/* initialize */
      if code ^= 0
      then return;					/* trouble with rewind */

      call synchronize (cP, code);			/* synchronize */
      if code ^= 0
      then return;					/* trouble with synch */
      errc = 10;					/* set error retry count */
      tseg.sync = 1;				/* synchronous for order codes */
      tseg.buffer_count = 0;				/* indicate order code to tdcm */

      i = index (codechart, operation);			/* pick up index for order code */
      if i = 0
      then
         do;					/* illegal operation */
	  code = error_table_$fatal_error;
	  return;
         end;
      else if i = 49
      then i = 13 + ccount;				/* set density index */
      else i = i / 4 + 1;

      if i = 8
      then
         do;					/* rewind */
	  call tdcm_$tdcm_set_signal (addr (tseg), code); /* set signal */
	  if code ^= 0
	  then go to er_fatal;			/* troubles */
	  cseg.wait_switch (drive_number) = "1"b;	/* set switch for rewind wait */
         end;

rtryo:
      tseg.command_queue (1) = bin (oplist (i));		/* set operation code */
      tseg.command_count = 1;				/* only one order code */
      reset_wait = "0"b;				/* tdcm signal not to be reset */

      call tdcm_$tdcm_iocall (addr (tseg), code);		/* have tdcm do my thing */
      if code ^= 0
      then
         do;					/* did tdcm call fail? */
er_fatal:
	  reset_wait = "1"b;			/* reset tdcm signal if set */
	  code = error_table_$fatal_error;		/* tdcm failure is fatal */
	  go to wait_test;				/* check tdcm signal */
         end;

      hdw_status.bits = tseg.hardware_status || (36)"0"b;	/* pad hardware status to 72 bits */
      call tape_ansi_interpret_status_ (addr (hdw_status)); /* generate error code structure from hdw status */

      if i = 6
      then return;					/* request status - exit because any result is ok */
      if i = 7
      then return;					/* reset status - ditto */

      if tseg.completion_status = 1
      then
         do;					/* implies Subsystem Ready major status */
	  if i = 4
	  then go to er_notry;			/* forward file didn't get EOF: error */
	  if i < 3
	  then
	     do;					/* bsf, bsr - are they at BOT? */
	        if check (tape_status_$ready_at_bot)
	        then
		 do;				/* minor status shows tape at BOT */
		    code = error_table_$positioned_on_bot;
						/* not an error */
		    return;
		 end;
	        else
		 do;				/* not at BOT */
		    if i = 1
		    then code = error_table_$fatal_error;
						/* bad if bsf */
		    return;
		 end;
	     end;
	  go to wait_test;				/* ok: check tdcm signal */
         end;

      if hdw_status.major = tape_status_$end_of_file
      then
         do;					/* End of File major status */
	  go to eof (i);				/* perform appropriate action */
eof (1):
eof (4):
	  return;					/* bsf/fsf - normal */
eof (2):
eof (5):
	  code = error_table_$eof_record;		/* bsr/fsr - an event, not an error */
	  return;					/* exit */
eof (3):
eof (10):						/* ers/eof - error, no retry */
eof (8):
eof (9):
eof (11):
	  go to er_notry;				/* rew/run/sdn - error, give up */
         end;

      if hdw_status.major = tape_status_$device_data_alert
      then
         do;					/* Device Data Alert major status */
	  if hdw_status.no_minor = 1
	  then
	     do;					/* simple case ? */
	        if hdw_status.minor (1) = tape_status_$end_of_tape
	        then
		 do;				/* EOT? */
		    code = error_table_$eov_on_write;
		    return;
		 end;
	     end;
	  if i = 3
	  then
	     do;					/* multiple errors - erase case */
	        tseg.command_queue (2) = bin (fsr);	/* recovery will forward space after backspace */
	        go to er_retry;			/* retry with positioning */
	     end;
	  if i = 10
	  then
	     do;					/* write eof case */
	        tseg.command_queue (2) = bin (ers);	/* set recovery code to erase bad tape mark */
	        go to er_retry;			/* retry with positioning */
	     end;
	  go to er_notry;				/* give up */
         end;

      if hdw_status.major = tape_status_$mpc_device_data_alert
      then
         do;					/* MPC Device Data Alert major status */
	  if i = 10
	  then
	     do;					/* write eof case */
	        tseg.command_queue (2) = bin (ers);	/* erase the bad tape mark */
	        go to er_retry;			/* retry it */
	     end;
	  go to er_notry;				/* give up on any other order */
         end;

      if hdw_status.major = tape_status_$command_reject
      then
         do;					/* Command Reject major status */
	  if i < 3
	  then
	     do;					/* bsf or bsr cases */
	        if check (tape_status_$reject_at_bot)
	        then
		 do;				/* was tape at BOT? */
		    code = error_table_$positioned_on_bot;
						/* set return code */
		    return;			/* exit */
		 end;
	     end;					/* other bsf/bsr cases fall through */
         end;					/* other orders fall through */


/* Device Busy major status */
/* MPC Device Attention major status */
/* MPC Command Reject major status */
/* Device Attention major status */

er_notry:
      reset_wait = "1"b;				/* reset tdcm signal if set */
      code = error_table_$tape_error;

wait_test:
      if cseg.wait_switch (drive_number)
      then if reset_wait
	 then
	    do;					/* rewind at bot or error */
	       call tdcm_$tdcm_reset_signal (addr (tseg), 0);
	       cseg.wait_switch (drive_number) = "0"b;
	    end;
      return;					/* return to caller */

er_retry:
      if errc > 0
      then
         do;					/* has retry count been exhausted? */
	  tseg.command_queue (1) = bin (bsr);		/* set tdcm to backspace 1 record */
	  tseg.command_count = 2;			/* error code has set tseg.command_queue (2) */
	  call tdcm_$tdcm_iocall (addr (tseg), code);	/* do io */
	  if code ^= 0
	  then go to er_fatal;			/* tdcm failed - give up */
	  if tseg.completion_status = 1
	  then go to rtryo;				/* io was uneventful - retry order */
	  hdw_status.bits = tseg.hardware_status || (36)"0"b;
						/* trouble - get status */
	  call tape_ansi_interpret_status_ (addr (hdw_status));
						/* interpret it */
	  if hdw_status.major = tape_status_$end_of_file
	  then go to rtryo;				/* well, EOF is reasonable */
	  if hdw_status.no_minor = 1
	  then
	     do;					/* simple case? */
	        if hdw_status.minor (1) = tape_status_$end_of_tape
	        then go to rtryo;			/* so is EOT */
	     end;
         end;
      go to er_notry;				/* exhausted or non-reasonable */

setup:
   proc;						/* internal proc for call initialization */

dcl   1 wait_list,					/* parameter lists for block */
        2 n		        fixed bin,
        2 chn		        fixed bin (71);

dcl   1 message,
        2 channel		        fixed bin (71),
        2 mess		        fixed bin (71),
        2 sender		        bit (36),
        2 origin,
	3 dev_sig		        bit (18) unal,
	3 ring		        bit (18) unal,
        2 channel_index	        fixed bin;


      cP = CP;					/* copy pointer */
      code = 0;					/* zero out rc */

      do drive_number = lbound(cseg.vl, 1) to cseg.vcN
         while (cseg.vl(drive_number).tape_drive ^= tseg.drive_name);
         end;

      if drive_number > cseg.vcN then do;
         code = error_table_$fatal_error;
         return;
         end;

      if cseg.wait_switch (drive_number)
      then
         do;					/* see if tape rewinding */
	  cseg.wait_switch (drive_number) = "0"b;	/* clear switch */
wait:
	  wait_list.n = 1;				/* initialize arg for block */
	  wait_list.chn = tseg.ev_chan;
	  call ipc_$block (addr (wait_list), addr (message), code);
						/* go blocked waiting for tape rewind */
	  if code ^= 0
	  then code = error_table_$fatal_error;
	  call tdcm_$tdcm_reset_signal (addr (tseg), 0);	/* reset */
         end;					/* end of code for rewind wait */
      return;					/* return to main line */
   end;						/* end of procedure setup */

check:
   procedure (min_code) returns (bit (1));		/* internal proc for status checking */

dcl   min_code		        fixed bin (35),	/* minor status code to be checked */
      ix			        fixed bin;		/* index into minor status code array */

      do ix = 1 to hdw_status.no_minor;			/* check each element */
         if min_code = hdw_status.minor (ix)
         then return ("1"b);				/* got it */
      end;
      return ("0"b);				/* not there */

   end check;

   end tape_ansi_tape_io_;




		    tape_status_.alm                11/05/86  1318.2r w 11/04/86  1038.1       52623



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

""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
"
"  N__a_m_e:  tape_status_
"
"       An error table segment defining a unique status code for
"  each possible major and sub-status generated by the MTS500
"  Magnetic Tape Subsystem.
"
"  0) Created: Oct. 21, 1974 by Ross E. Klinger
"
"  1) Modified: March 5, 1976 by R. E. Klinger to add a new
"     Command Reject substatus, Invalid Density.
"
"  2) Converted to ALM January 1980 by C. Hornig.
"
"
"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""

	include	et_macros

	et	tape_status_

	ec	command_reject,MTS010,(Command Reject.)
	ec	invalid_density,MTS015,(Command Reject - Invalid Density.)
	ec	invalid_opcode,MTS020,(Command Reject - Invalid Op Code.)
	ec	invalid_device_code,MTS030,(Command Reject - Invalid Device Code.)
	ec	invalid_idcw_parity,MTS040,(Command Reject - Invalid IDCW Parity.)
	ec	reject_at_bot,MTS050,(Command Reject - Positioned at BOT.)
	ec	read_after_write,MTS060,Command Reject - Forward Read After Write.;
	ec	nine_track_error,MTS070,(Command Reject - 9-Track Error.)
	ec	mpc_command_reject,MTS080,(MPC Command Reject.)
	ec	illegal_procedure,MTS090,(MPC Command Reject - Illegal Procedure.)
	ec	illegal_lc_number,MTS100,(MPC Command Reject - Illegal LC Number.)
	ec	illegal_susp_lc_number,MTS110,(MPC Command Reject - Illegal Suspended LC Number.)
	ec	continue_not_set,MTS120,(MPC Command Reject - Continue Bit Not Set.)
	ec	end_of_file,MTS130,(End of File.)
	ec	seven_track_eof,MTS140,(End of File - End of File Mark (7-Track).)
	ec	nine_track_eof,MTS150,(End of File - End of File Mark (9-track).)
	ec	data_alert,MTS160,(End of File - Data Alert Condition.)
	ec	single_char_record,MTS170,(End of File - Single Character Record.)
	ec	device_data_alert,MTS180,(Device Data Alert.)
	ec	transfer_timing,MTS190,(Device Data Alert - Transfer Timing Alert.)
	ec	blank_tape_on_read,MTS200,(Device Data Alert - Blank Tape on Read.)
	ec	bit_during_erase,MTS210,(Device Data Alert - Bit Detected During Erase Operation.)
	ec	transmission_parity,MTS220,(Device Data Alert - Transmission Parity Alert.)
	ec	lateral_parity,MTS230,(Device Data Alert - Lateral Tape Parity Alert.)
	ec	longitudinal_parity,MTS240,(Device Data Alert - Longitudinal Tape Parity Alert.)
	ec	end_of_tape,MTS250,(Device Data Alert - End of Tape Mark.)
	ec	mpc_device_data_alert,MTS260,(MPC Device Data Alert.)
	ec	transmission_alert,MTS270,(MPC Device Data Alert - Transmission Alert.)
	ec	inconsistent_command,MTS280,(MPC Device Data Alert - Inconsistent Command.)
	ec	sum_check_error,MTS290,(MPC Device Data Alert - Sum Check Error.)
	ec	byte_locked_out,MTS300,(MPC Device Data Alert - Byte Locked Out.)
	ec	pe_burst_error,MTS310,(MPC Device Data Alert - PE-Burst Write Error.)
	ec	preamble_error,MTS320,(MPC Device Data Alert - Preamble Error.)
	ec	marginal_condition,MTS330,(MPC Device Data Alert - Marginal Condition.)
	ec	multitrack_error,MTS340,(MPC Device Data Alert - Multitrack Error.)
	ec	skew_error,MTS350,(MPC Device Data Alert - Skew Error.)
	ec	postamble_error,MTS360,(MPC Device Data Alert - Postamble Error.)
	ec	nrzi_ccc_error,MTS370,(MPC Device Data Alert - NRZI CCC Error.)
	ec	code_alert,MTS380,(MPC Device Data Alert - Code Alert.)
	ec	device_attention,MTS390,(Device Attention.)
	ec	write_protect_attention,MTS400,(Device Attention - Write Protected.)
	ec	no_such_device,MTS410,(Device Attention - No Such Device.)
	ec	device_in_standby,MTS420,(Device Attention - Device in Standby.)
	ec	device_check,MTS430,(Device Attention - Device Check.)
	ec	blank_tape_on_write,MTS440,(Device Attention - Blank Tape on Write.)
	ec	mpc_device_attention,MTS450,(MPC Device Attention.)
	ec	configuration_error,MTS460,(MPC Device Attention - Configuration Switch Error.)
	ec	multiple_devices,MTS470,(MPC Device Attention - Multiple Devices.)
	ec	illegal_device_id,MTS480,(MPC Device Attention - Illegal Device ID Number.)
	ec	incompatible_mode,MTS490,(MPC Device Attention - Incompatible Mode.)
	ec	tca_malfunction_port0,MTS500,(MPC Device Attention - TCA Malfunction Port 0.)
	ec	tca_malfunction_port1,MTS510,(MPC Device Attention - TCA Malfunction Port 1.)
	ec	tca_malfunction_port2,MTS520,(MPC Device Attention - TCA Malfunction Port 2.)
	ec	tca_malfunction_port3,MTS530,(MPC Device Attention - TCA Malfunction Port 3.)
	ec	mth_malfunction,MTS540,(MPC Device Attention - MTH Malfunction.)
	ec	multiple_bot,MTS550,(MPC Device Attention - Multiple BOT.)
	ec	device_busy,MTS560,(Device Busy.)
	ec	in_rewind,MTS570,(Device Busy - In Rewind.)
	ec	device_reserved,MTS580,(Device Busy - Device Reserved.)
	ec	alternate_channel,MTS590,(Device Busy - Alternate Channel in Control.)
	ec	device_loading,MTS600,(Device Busy - Device Loading.)
	ec	subsystem_ready,MTS610,(Peripheral Subsystem Ready.)
	ec	device_ready,MTS620,(Peripheral Subsystem Ready - Device Ready.)
	ec	write_protected,MTS630,(Peripheral Subsystem Ready - Write Protected)
	ec	ready_at_bot,MTS640,(Peripheral Subsystem Ready - Positioned at BOT)
	ec	nine_track_handler,MTS650,(Peripheral Subsystem Ready - 9-Track Handler.)
	ec	two_bit_fill,MTS660,(Peripheral Subsystem Ready - 2-Bit Fill.)
	ec	four_bit_fill,MTS670,(Peripheral Subsystem Ready - 4-Bit Fill.)
	ec	six_bit_fill,MTS680,(Peripheral Subsystem Ready - 6-Bit Fill.)
	ec	ascii_alert,MTS690,(Peripheral Subsystem Ready - ASCII Alert.)

	end




		    tdcm_.pl1                       11/30/82  1535.6rew 11/30/82  1207.1      385290



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tdcm_:
     procedure;

/*	This is the non-ring 0 version of the tape DCM.
   *	Recoded from ring 0 version by Bill Silver on 09/30/74.
   *	Modified for preloaded volumes by Michael R. Jordan on 04/28/78.
   *	Modified 7/79 by R.J.C. Kissel to user version 1 tseg.
   *	Modified 03/82 by Chris Jones for version 2 tseg.
   *	Modified 3/82 by J. A. Bush for Marker interrupt processing
   *	Modified 7/13/82 by J. A. Bush to fix some interrupt processing bugs
   *
   *	This version of this program is part of the initial "dummy"
   *	installation of RCP.
   *
   *	tdcm_ interfaces with RCP in order to perform device management
   *	functions.  It interfaces with IOI in order to perform the
   *	actual tape I/O. Notes about this procedure:
   *	1.  In general all entry points function in the same way.
   *	2.  The caller of tdcm_ must be aware that the first tseg buffer
   *	    and tseg.drive_number are not valid between the call to
   *	    tdcm_$tdcm_attach and the first call to tdcm_$tdcm_message.
   *	3.  tdcm_$tdcm_message must be called after the call to tdcm_attach or
   *	    after a call to tdcm_$tdcm_detach in which the drive assignment has
   *	    been retained.  Subsequent calls to tdcm_$tdcm_message will temporarily
   *	    still type a mount message on the operator's console.
   *	4.  I/O modules no longer need to check that the tape drive is ready or
   *	    that the volume is at BOT or that the write ring is set correctly.
   *	    RCP does all of this checking.
   *	5.  tdcm_$tdcm_priv_attach is no longer supported.  RCP checks to see
   *	    if a process is privileged.
   *	6.  tdcm_$tdcm_mount_bit_set and tdcm_$tdcm_mount_bit_get are no
   *	    longer supported.
   *	7.  A new entry point, tdcm_set_disposition, is available.
   *	    It allows the user to specify a disposition value to be given
   *	    to RCP when the tape drive is detached.
   *	8.  Two new entry points are now available: tdcm_set_buf_size and
   *	    tdcm_get_buf_size;  They allow the caller to adjust the size of
   *	    the tdcm_ I/O buffer.
*/

/*		ARGUMENT  DATA		*/

dcl      arg_buf_size	  fixed bin;		/* (I/O) Size of tdcm_ I/O buffer. */
dcl      arg_call_data_ptr	  ptr;			/* (I) Pointer to event call data structure. */
dcl      arg_disposition	  bit (*);		/* (I) Disposition value given to RCP. */
dcl      arg_ecode		  fixed bin (35);		/* (O) Standard error_table_ code. */
dcl      arg_reel_name	  char (*);		/* (I) Tape reel ID name plus qualifiers. */
dcl      arg_tsegp		  ptr;			/* (I) Pointer to user's tseg. */
dcl      arg_val_level	  fixed bin;		/* (I) Validation level to be set. */
dcl      arg_write_sw	  fixed bin (1);		/* (I) 1 => write, 0 => read. */


/*		AUTOMATIC  DATA		*/

dcl      1 event_data	  like call_data;		/* Not really used. */

dcl      call_data_ptr	  ptr;			/* Pointer to event call data structure. */
dcl      wbuf_ptr		  ptr;			/* Pointer to buffer in IOIworkspace. */

dcl      buf_size		  fixed bin;		/* Used to copy buffer size argument. */
dcl      data_size		  fixed bin;		/* Number of words to be moved by based_data. */
dcl      dcw_tally		  fixed bin (18);		/* Number of words to be move by single DCW. */
dcl      ecode		  fixed bin (35);		/* Temporary error code. */
dcl      fix		  fixed bin;		/* Used to correct read count. */
dcl      tmr		  bit (1) aligned;
dcl      ck_level		  fixed bin (3);		/* interrupt level returned by CK_STATQ */
dcl      (i, sqx)		  fixed bin;
dcl      listx		  fixed bin;		/* Index to last IDCW that was executed. */
dcl      new_val_level	  fixed bin;		/* Used to copy validation level argument. */
dcl      op_count		  fixed bin;		/* Number of commands or buffers in I/O. */
dcl      (tbuf_num, wbuf_num)	  fixed bin;		/* Number of tseg buffer. */
dcl      tot_data_size	  fixed bin;		/* Tot num of words written with 1 connect. */
dcl      special_flag	  bit (1) aligned;		/* ON => we have special status. */
dcl      special_status_word	  bit (36) aligned;		/* Status word for special interrupts. */
dcl      data_idcw		  bit (36) aligned;		/* to copy current data xfer idcw into */
dcl      (io_time, delta)	  fixed bin (71);
dcl      (pfs, pf_code)	  fixed bin (35);

/*		BASED  DATA		*/

dcl      based_data		  (data_size) fixed bin (35) aligned based;
						/* Used to move data. */

dcl      based_idcw		  bit (36) aligned based (idcwp);

dcl      1 call_data	  based (call_data_ptr) aligned,
						/* Data structure for event calls. */
	 2 channel_id	  fixed bin (71),
	 2 message	  fixed bin (71),
	 2 sender		  bit (36),
	 2 orgin,
	 ( 3 dev_signal	  bit (18),
	   3 ring		  bit (18)
	   )		  unaligned,
	 2 data_ptr	  ptr;			/* Points to IOIworkspace. */


/*		EXTERNAL ENTRIES CALLED	*/

dcl      (addr, addrel, baseptr, bin, bit, clock, divide, hbound, min, ptr, rel, string, substr)
			  builtin;

dcl      (
         error_table_$bad_arg,
         error_table_$buffer_big,
         error_table_$invalid_state,
         error_table_$out_of_main_memory,
         error_table_$unimplemented_version,
         error_table_$net_timeout,
         error_table_$too_many_buffers
         )		  fixed bin (35) external;

dcl      display_meters	  bit (1) aligned static options (constant) init ("0"b);
						/* if meters are to be displayed at detach time, set to ("1"b) */

dcl      convert_ipc_code_	  entry (fixed bin (35));
dcl      hcs_$wakeup	  entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl      ioi_$connect	  entry (fixed bin, fixed bin, fixed bin (35));
dcl      ioi_$set_event	  entry (fixed bin, fixed bin (71), fixed bin (35));
dcl      ioi_$get_special_status
			  entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35));
dcl      ipc_$drain_chn	  entry (fixed bin (71), fixed bin (35));
dcl      ipc_$block		  entry (ptr, ptr, fixed bin (35));
dcl      rcp_$promote	  entry (bit (36) aligned, fixed bin, fixed bin (35));
dcl      tdcm_$tdcm_reset_signal
			  entry (ptr, fixed bin (35));
dcl      tdcm_attach_	  entry (ptr, fixed bin (35));
dcl      tdcm_detach_	  entry (ptr, fixed bin (35));
dcl      tdcm_message_	  entry (ptr, ptr, char (*), fixed bin (1), fixed bin (35));
dcl      mhcs_$get_seg_usage_ptr
			  entry (ptr, fixed bin (35), fixed bin (35));
dcl      ioa_		  entry options (variable);
%page;
%include tseg;
%page;
%include tdcm_info;
%page;
%include ioi_stat;
%page;
%include iom_stat;
%page;
%include iom_pcw;
%include iom_dcw;
%page;
tdcm_attach:
     entry (arg_tsegp, arg_ecode);

/*	The following entry points will be implemented as external procedures.
   *	This is done in order to reduce the size of tdcm_.pl1.
*/
	call tdcm_attach_ (arg_tsegp, arg_ecode);
	return;




tdcm_message:
     entry (arg_tsegp, arg_reel_name, arg_write_sw, arg_ecode);

	call SETUP;				/* Initialize and validate. */
	ws.info.subset_size = divide (hbound (ws.rw_list, 1), 2, 17, 0);
						/* set up max subset size */
	call tdcm_message_ (tsegp, ws_ptr, arg_reel_name, arg_write_sw, arg_ecode);
	return;




tdcm_detach:
     entry (arg_tsegp, arg_ecode);

	call SETUP;				/* Initialize and validate. */

	if ws.info.flags.good_ws then do;
	     call REWIND_TAPE;			/* TERMPORARY for DUMMY RCP. */
	     call tdcm_$tdcm_reset_signal (tsegp, ecode); /* set up to ignore special interrupt */
	     if display_meters then do;		/* this will normally be shut off */
		call mhcs_$get_seg_usage_ptr (tsegp, pfs, pf_code);
		call ioa_ ("^/Total number of data xfer I/O calls:^2-^d", ws.number_ios + 1);
		call ioa_ ("Highest number of blocks/data xfer I/O call:^-^d", ws.info.block_count);
		call ioa_ ("Average Time between data xfer I/O calls:^-^.3f MS",
		     float (ws.io_delta / ws.number_ios) / 1000);
		call ioa_ ("Longest time between data xfer I/O calls:^-^.3f MS", float (ws.high_delta) / 1000);
		call ioa_ ("Shortest time between data xfer I/O calls:^-^.3f MS", float (ws.low_delta) / 1000);
		call ioa_ ("Number of calls to ipc_$block:^2-^d", ws.info.block);
		call ioa_ ("Times status queue processed w/o going blocked:^-^d", ws.info.no_block);
		call ioa_ ("Total number of terminate interrupts:^2-^d", ws.info.term_st);
		call ioa_ ("Number of terminate interrupts without errors:^-^d", ws.info.term_ne);
		call ioa_ ("Total number of marker interrupts:^2-^d", ws.info.mark_st);
		call ioa_ ("Most consecutive number of marker interrupts:^-^d", ws.most_consec_mark);
		call ioa_ ("Number of page faults taken on tseg:^2-^d", pfs);
		call mhcs_$get_seg_usage_ptr (ws_ptr, pfs, pf_code);
		call ioa_ ("Number of page faults taken on workspace:^-^d^/", pfs);
	     end;
	end;
	call tdcm_detach_ (ws_ptr, arg_ecode);
	return;
%page;
tdcm_set_signal:
     entry (arg_tsegp, arg_ecode);

/*	This entry point is called whenever the caller wants to be waked
   *	up when a special interrupt is received from the tape drive.
   *	Until this entry is called all special interrupts will be ignored.
   *	In order to implement this feature we must change the event
   *	channel that IOIis using to communicate with us.  We will
   *	use an event call channel instead of the fast event channel.
   *	This means that when IOI sends a wakeup we will enter the call
   *	handler tdcm_$special_handler rather than being waked up in
   *	WAIT_FOR_STATUS.  If the tape drive is not yet attached we will save
   *	the ID of the event channel we want to use.  It will be set up with
   *	IOIafter the attachment is made.
*/
	call SETUP;				/* Initialize and validate. */

	if ws.info.flags.attached			/* If attached switch, else save. */
	then call ioi_$set_event (ws.info.ioix, ws.info.special_echan, ecode);
	else ws.info.init_echan = ws.info.special_echan;

	arg_ecode = ecode;
	return;





tdcm_reset_signal:
     entry (arg_tsegp, arg_ecode);

/*	This entry point is called when the caller is no longer
   *	interrested in special interrupts.  We will swap back the
   *	the event channels that we changed in tdcm_set_signal.
   *	We will use the fast event channel again.
*/
	call SETUP;				/* Initialize and validate. */

	if ws.info.flags.attached			/* If attached switch back, else save. */
	then call ioi_$set_event (ws.info.ioix, ws.info.fast_echan, ecode);
	else ws.info.init_echan = ws.info.fast_echan;

	arg_ecode = ecode;
	return;
%page;
tdcm_promote:
     entry (arg_tsegp, arg_val_level, arg_ecode);

/*	This entry point is called to promote the validation level of the
   *	specified tape drive.  The validation level will already be set
   *	to the caller's validation level.  If this entry point is called
   *	before this drive is attached we will get an error from IOI.
*/
	call SETUP;				/* Initialize and validate. */

	new_val_level = arg_val_level;		/* Copy validation level caller wants to set. */
	call rcp_$promote (ws.info.rcp_id, new_val_level, ecode);

	arg_ecode = ecode;
	return;





tdcm_set_disposition:
     entry (arg_tsegp, arg_disposition, arg_ecode);

/*	This entry is called to specify a disposition to be passed to RCP
   *	when this drive is detached.  If this entry point is called
   *	before this drive is attached we will return an error.
*/
	call SETUP;

	if ^ws.info.flags.attached			/* Make sure tape drive is attached. */
	then do;					/* Not attached, return error. */
	     arg_ecode = error_table_$invalid_state;
	     return;
	end;

	ws.info.disposition = arg_disposition;		/* Save caller's disposition. */

	arg_ecode = ecode;
	return;
%page;
tdcm_set_buf_size:
     entry (arg_tsegp, arg_buf_size, arg_ecode);

/*	This entry point is called to set the size of the tdcm_ I/O buffer.
   *	The default tdcm_ I/O buffer size is 2080 words.  The actual buffer size
   *	used is also a function of the maximum workspace size available from IOI.
   *	This entry point must be called before the first call to tdcm_$tdcm_message.
*/
	call SETUP;

	buf_size = arg_buf_size;			/* Copy argument. */

	if ws.info.flags.attached then do;		/* Is tape drive already attached? */
	     arg_ecode = error_table_$invalid_state;	/* Yes, buffer size already established. */
	     return;
	end;

	if buf_size < 1 then do;			/* Is buffer size too small? */
	     arg_ecode = error_table_$bad_arg;		/* Yes, don't change the buffer size. */

	     return;
	end;
	if buf_size = 1040 * 6 then do;		/* tape_mult_ with "-sys" option? */
	     ws.info.flags.allow_marker = "1"b;		/* yes, do marker interrupt processing */
	     buf_size = hbound (ws.rw_list, 1) * 1040;	/* set wks to mak size allowed */
	end;
	ws.info.buf_size = buf_size;			/* Set buffer size. */

	arg_ecode = 0;
	return;



tdcm_get_buf_size:
     entry (tsegp, arg_buf_size, arg_ecode);

	call SETUP;

	if ^ws.info.flags.attached then do;		/* Is tape drive attached? */
	     arg_buf_size = 0;			/* No, buffer size value not valid yet. */
	     arg_ecode = error_table_$invalid_state;
	     return;
	end;

	if ws.info.flags.allow_marker then		/* if we phonied up buffer size.. */
	     arg_buf_size = ws.info.subset_size * 1040;	/* don't tell user */
	else arg_buf_size = ws.info.buf_size;		/* Return actual buffer size. */
	arg_ecode = 0;
	return;
%page;
tdcm_iocall:
     entry (arg_tsegp, arg_ecode);

/*	This entry point is called to perform actual I/O operations on the
   *	specified tape drive.  There are two main types of I/O operations
   *	performed:  non-data transfer commands, and reads or writes.
   *	If this entry point is called before the tape drive is attached
   *	we will get an error from IOI.
*/
	call SETUP;				/* Initialize and verify. */

	tseg.completion_status = 0;			/* Initialize to imply no  status. */

IOCALL_LOOP:					/* Check status and perform I/O. */
	if ws.info.flags.connected then		/* Are _w_e currently performing I/O? */
	     if ^ws.info.flags.allow_marker then	/* and not doing marker processing? */
		call CHECK_STATUS;			/* Yes, wait for it to complete. */
	     else if tseg.command_count > 0 |		/* allowing markers, but non-data xfer or */
		     tseg.command_count + tseg.buffer_count <= 0 then
						/* if no I/O to perform */
		call CHECK_STATUS;			/* then wait for terminate status */
	if tseg.command_count + tseg.buffer_count <= 0 then
	     goto IOCALL_RETURN;			/* No I/O to perform. */

/* Write switch in tseg => error type. */
	if tseg.command_count > 0 then		/* Are there any non-data transfer commands? */
	     call NON_DATA_TRANSFER;			/* Yes, do them first. */
	else if ws.info.flags.allow_marker then		/* if doing marker interrupt processing... */
	     call MARKER_READ_WRITE;			/* go to that routine */
	else call READ_WRITE;			/* No, caller must want to read or write. */

	if tseg.sync ^= 0 then			/* Does caller want us to wait? */
	     goto IOCALL_LOOP;			/* Yes, wait until operation complete. */

IOCALL_RETURN:
	arg_ecode = ecode;
	return;
%page;
special_handler:
     entry (arg_call_data_ptr);

/*	This entry point is called to handle wakeups on the event call
   *	channel, special_echan.  This event channel is given to IOI when
   *	the user calls tdcm_set_signal.  We will call IOI to get the
   *	status for the current interrupt.
*/
	call_data_ptr = arg_call_data_ptr;		/* Get pointer to event call data. */
	ws_ptr = call_data.data_ptr;			/* The event data ptr is the workspace ptr. */

	isp = addr (ws.statq (ws.info.statqx));		/* Get pointer to current IOI status queue entry. */
	if ^istat.completion.st then			/* If no status then ignore status queue. */
	     goto GET_SPECIAL_STATUS;			/* Go see if there is special status. */

	goto SLEVEL (istat.level);			/* Go process according to level. */

SLEVEL (7):					/* Should not get special status in queue. */
	if ws.info.statqx = hbound (ws.statq, 1) then	/* Get index of next status queue entry. */
	     ws.info.statqx = 1;			/* If at end wraparound. */
	else ws.info.statqx = ws.info.statqx + 1;

	istat.completion.st = "0"b;			/* Free this status queue entry. */

	goto GET_SPECIAL_STATUS;

/*	This is a terminate of system fault interrupt.  Either of these
   *	interrupts signals the completion of a connect.  tdcm_iocall will
   *	always wait on the wait list event channel for the completion
   *	of a connect.  Therefore we must send a wakeup over that channel.
   *	We will not actually process the status from this interrupt.
   *	It will be processed by WAIT_FOR_STATUS when it wakes up.
*/
SLEVEL (1):					/* System fault or terminate interrupt. */
SLEVEL (3):					/* Send a wakeup to WAIT_FOR_STATUS. */
SLEVEL (5):					/* Marker, treat like terminate */
	call hcs_$wakeup (ws.info.process_id, ws.info.wait_list.wait_echan, 0, ecode);

/*	One way or another we have processed any status in the queue.
   *	Now we must look for a special interrupt.  Since this entry
   *	was called we know that the caller wants to be signalled
   *	when there is a special interrupt.  We will send a wakeup to him
   *	over the user event channel.  The caller should be blocked himself
   *	waiting for this wakeup.
*/
GET_SPECIAL_STATUS:
	call ioi_$get_special_status (ws.info.ioix, special_flag, special_status_word, ecode);
	if ecode ^= 0 then
	     return;
	if special_flag then			/* If we got a special signal user. */
	     call hcs_$wakeup (ws.info.process_id, ws.info.user_echan, 0, ecode);
	return;
%page;
/*	This label defines the location where all internal procedures will
   *	return if they encounter a fatal error.  This non-structured bit
   *	of programming is done for the sake of efficiency.  It means that
   *	there does not have to be a check for errors after each call to
   *	an internal procedure.
*/

INTERNAL_PROC_RETURN:
	arg_ecode = ecode;				/* Return error code. */
	return;





SETUP:
     procedure;

/*	This procedure is called by all entry points except tdcm_attach.
   *	It gets a pointer to the IOI workspace that we are using.
   *	If we don't have a real IOI workspace yet we will temporarily
   *	use part of the tseg.
*/
	tsegp = arg_tsegp;				/* Copy argument. */

	if tseg.version_num ^= tseg_version_2 then do;
	     ecode = error_table_$unimplemented_version;
	     goto INTERNAL_PROC_RETURN;
	end;

	ecode = 0;

	if tseg.ws_segno = "0"b			/* Do we have a real IOI workspace yet? */
	then ws_ptr = addr (tseg.buffer (1));		/* No, use temporary workspace area. */
	else ws_ptr = baseptr (tseg.ws_segno);

     end SETUP;
%page;
WAIT_FOR_STATUS:
     procedure;

/*	This procedure is called when we must wait for a connect to terminate.
   *	We will always block on the status_echan event channel.  This is the
   *	event channel that we try to initiate as a fast channel.  If the
   *	interrupt which caused IOI to send this wakeup is not a terminate
   *	or system fault we will ignore the wakeup and go blocked again.
   *	When we return all the necessary processing of the interrupt will have
   *	been performed.  Then the connect will be considered complete.
*/
WAIT_LOOP:					/* Come here if we have to block again. */
	ws.info.meters.block = ws.info.meters.block + 1;	/* increment meter */
	call ipc_$block (addr (ws.info.wait_list), addr (event_data), ecode);
	if ecode ^= 0 then do;
	     call convert_ipc_code_ (ecode);
	     goto INTERNAL_PROC_RETURN;
	end;
	go to PROC_QUEUE;

PROCESS_QUEUE:
     entry;					/* entry called when we know a status queue entry is full */
	ws.info.meters.no_block = ws.info.meters.no_block + 1;
						/* increment meter */
PROC_QUEUE:
	isp = addr (ws.statq (ws.info.statqx));		/* Get pointer to current IOI status queue entry. */
	if ^istat.completion.st then			/* If no status then we got an extra wakeup. */
	     goto WAIT_LOOP;			/* Wait again. */

	if ws.info.statqx = hbound (ws.statq, 1) then	/* Get index of next status queue entry. */
	     ws.info.statqx = 1;			/* If at end wraparound. */
	else ws.info.statqx = ws.info.statqx + 1;

	istat.completion.st = "0"b;			/* Free this status queue entry. */
	statp = addr (istat.iom_stat);		/* Get pointer to IOM status. */
	listx = istat.offset;			/* Get absolute listx from IOI. */
	if ws.info.flags.ndtrans then			/* Convert listx depending upon type of DCW list. */
	     op_count = listx - ws.info.ndt_offsetx + 1;
	else if ws.info.flags.large_rec then		/* One record longer than 4096 words? */
	     op_count = 1;
	else op_count = divide ((listx - ws.info.rw_offsetx + 2), 2, 17, 0);
	goto WLEVEL (istat.level);			/* Go process according to level. */

WLEVEL (7):					/* Should not get special status in queue. */
	goto WAIT_LOOP;				/* Ignore, wait for real status. */

WLEVEL (1):					/* System fault. */
	istat.iom_stat = "0"b;			/* Clear IOM status. */
	status.major = "1111"b;			/* This denotes a system fault. */

WLEVEL (3):					/* Terminate interrupt.  Process together. */
	ws.info.term_st = ws.info.term_st + 1;		/* increment meter */
	ws.info.consec_mark = 0;			/* reset this meter */
	if op_count > ws.info.subset_size then do;	/* if doing marker processing, must be on second half */
	     op_count = op_count - ws.info.subset_size;	/* set for only number of buffers since last marker */
	     ws.info.mark_offset = ws.info.subset_size;	/* set base buffer */
	end;
	else ws.info.mark_offset = 0;			/* first buffer subset */
	ws.info.flags.connected = "0"b;		/* Connect has now completed. */
	if ws.info.flags.reading then			/* Was this connect for a read? */
	     call PROCESS_INPUT;			/* Yes, extra processing needed for input. */

	tseg.hardware_status = istat.iom_stat;		/* Return iom status to user. */

	if ^istat.completion.er then do;		/* Was there an error? */
	     tseg.completion_status = 1;		/* No, tell user everything is OK. */
	     ws.info.term_ne = ws.info.term_ne + 1;	/* increment meter */
	end;
	else do;					/* Yes, there was an error. */
	     tseg.completion_status = 2;		/* Tell user that he got bad status. */
	     tseg.error_buffer = op_count;		/* Tell him how far he got. */
	     if (status.major = "0011"b) | (status.major = "1011"b) then
						/* Count data alert errors. */
						/* And MPC data alert errors. */
		ws.info.error_count = ws.info.error_count + 1;
	     if istat.completion.time_out then		/* IF time-out set error code. */
		ecode = error_table_$net_timeout;
	     goto INTERNAL_PROC_RETURN;		/* Return directly to user. */
	end;
	return;

WLEVEL (5):					/* Marker interrupt */
	ws.info.mark_st = ws.info.mark_st + 1;		/* increment meter */
	ws.consec_mark = ws.consec_mark + 1;		/* increment meter */
	if ws.consec_mark > ws.most_consec_mark then	/* if this is bigger than previous high */
	     ws.most_consec_mark = ws.consec_mark;	/* change the value */
	if ws.info.flags.reading then do;		/* if reading extra processing required */
	     tmr = "0"b;				/* reset terminate condition */
	     do i = op_count by -1 while (^tmr);	/* find the real marker index */
		if i = 0 then			/* if we got to the beginning of the list.. */
		     i = hbound (ws.rw_list, 1);	/* reset back to the end */
		idcwp = addr (ws.rw_list (i).idcw);
		if idcw.control = "11"b then do;	/* if true, we found the marker */
		     tmr = "1"b;			/* set terminate conditon */
		     op_count = i;			/* adjust  op_count to corrected value */
		end;
	     end;
	     if op_count > ws.info.subset_size then do;	/* if doing marker processing, must be on second half */
		op_count = op_count - ws.info.subset_size;
						/* set for only number of buffers since last marker */
		ws.info.mark_offset = ws.info.subset_size;
						/* set base buffer */
	     end;
	     else ws.info.mark_offset = 0;		/* first buffer subset */
	     call PROCESS_INPUT;			/* Yes, extra processing needed for input. */
	end;
	tseg.hardware_status = istat.iom_stat;		/* copy marker status to return to user */
	tseg.completion_status = 1;			/* indicate no error */

     end WAIT_FOR_STATUS;
%page;
PROCESS_INPUT:
     procedure;

/*	This procedure is called to process input data found in the IOI workspace.
   *	We will copy the input data from the workspace into the tseg buffers.
   *	We must copy the input buffers one at a time since the size of each tseg
   *	buffer may be much larger than the number of words that are actually used
   *	in each buffer.
*/
	if ws.info.flags.allow_marker then		/* if doing marker processing */
	     tbuf_num = ws.info.mark_offset + 1;	/* 1 to 1 relation between tseg buf and ws buf */
	else tbuf_num = ws.info.read_start;		/* otherwise start where he told us */

	if ws.info.flags.get_size then do;		/* Does caller want actual read count? */
						/* Yes, special case. */
	     fix = 0;				/* We may have to fix the read count. */
	     if (status.char_pos = "1"b3) & (^istat.completion.er) then
						/* NZ char count & no error? */
		if (status.sub & "04"b3) = "04"b3 then
		     if addr (ws.rw_list (1).idcw) -> idcw.command ^= addr (ws.read_idcws (2)) -> idcw.command then
			fix = 1;			/* Fix, 9 track _a_n_d _n_o_t read tape 9. */
		     else ;
		else if (^status.eo) & ((status.sub & "60"b3) = "40"b3) then
		     fix = 1;			/* Fix, 7 track _a_n_d even _a_n_d 4 bit fill. */
	     dcw_tally = bin (status.tally, 12) + fix;	/* Compute correct tally residue. */
						/* Now return read count of first buffer. */
	     if (listx - ws.info.rw_offsetx) >= (divide (ws.info.buffer_size (1) + 4095, 4096, 17)) then
		data_size = ws.info.buffer_size (1) - dcw_tally;
	     else data_size = (listx - ws.info.rw_offsetx) * 4096 - dcw_tally;
	     tseg.buffer_size (ws.info.read_start) = data_size;
	end;

	do i = ws.info.mark_offset + 1 to ws.info.mark_offset + op_count;
						/* Copy buffers from workspace to tseg. */
	     data_size = ws.info.buffer_size (i);	/* Get size of this input buffer. */
	     dcwp = addr (ws.rw_list (i).dcw);		/* get correct dcw */
	     wbuf_ptr = ptr (addr (ws.buffer), dcw.address);
						/* and get ptr to data */
						/* Copy one input buffer into tseg. */
	     ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data = wbuf_ptr -> based_data;
	     tbuf_num = tbuf_num + 1;			/* Move to next tseg buffer. */
	end;

     end PROCESS_INPUT;
%page;
NON_DATA_TRANSFER:
     procedure;

/*	This procedure is called to set up non-data transfer IDCWs.
   *	Most fields in these non-data transfer IDCWs were set up when the
   *	the tape drive was attached.  We just have to fill in the actual
   *	device command codes and turn OFF the continue bits in the last
   *	IDCW.  We get the device commands from the tseg command queue.
*/
	op_count = tseg.command_count;		/* Get number of non-data transfer operations. */
	if op_count > hbound (ws.ndt_list, 1)		/* Make sure there are not too many. */
	then do;
	     ecode = error_table_$too_many_buffers;
	     goto INTERNAL_PROC_RETURN;
	end;

	do i = 1 to op_count;			/* Set up specified number of IDCWs. */
	     idcwp = addr (ws.ndt_list (i).idcw);	/* Get pointer to non-data transfer IDCW. */
	     idcw.command = bit (tseg.command_queue (i), 6);
						/* Copy device command. */
	     idcw.control = "10"b;			/* Turn ON continue in each IDCW. */
	end;

	idcw.control = "00"b;			/* Terminate list with last IDCW. */

	tseg.command_count = 0;			/* Tell caller we have picked up all commands. */
	ws.info.flags.reading = "0"b;			/* Not reading or writing. */
	ws.info.flags.ndtrans = "1"b;			/* Non-data transfer commands. */

	call TRY_TO_CONNECT (ws.info.ndt_offsetx);
	if ecode ^= 0 then
	     goto INTERNAL_PROC_RETURN;
	ws.info.flags.connected = "1"b;		/* Connect has been made. */

     end NON_DATA_TRANSFER;

/* CK_STATQ - subroutine to check if any status queue entry is full */

CK_STATQ:
     proc returns (bit (1) aligned);

	if ws.statq (ws.info.statqx).completion.st then	/* if status stored in this queue entry */
	     return ("1"b);				/* return true */
	else return ("0"b);				/* no status stored */

     end CK_STATQ;
%page;
MARKER_READ_WRITE:
     procedure;

/*	This procedure is called to set up the IDCWs and DCWs used to read
   *	or write data.  The write switch in the tseg tells us which type
   *	of operation is to be performed.
*/
	op_count = tseg.buffer_count;			/* Get number of buffers to read or write. */
	if op_count > ws.info.subset_size then do;	/* Did caller specify too many buffers? */
	     ecode = error_table_$too_many_buffers;
	     goto INTERNAL_PROC_RETURN;
	end;

	wbuf_ptr = addr (ws.buffer);			/* Get pointer to buffer area in IOI workspace. */
	tbuf_num = tseg.buffer_offset + 1;		/* Get number of first tseg buffer. */
	if tbuf_num > ws.info.subset_size then do;	/* if setting up second subset of buffers */
	     wbuf_num = ws.info.subset_size + 1;
	     wbuf_ptr = addrel (wbuf_ptr, ws.info.subset_size * 1040);
						/* start at end of first subset */
	end;
	else wbuf_num = 1;				/* no set up for first subset */
	if tseg.write_sw ^= 0 then do;		/* Are we reading or writing? */
	     ws.info.flags.reading = "0"b;		/* Writing not reading. */
	     data_idcw = ws.info.write_idcws (tseg.mode (tbuf_num));
						/* Writing. */
	end;
	else do;					/* Reading. */
	     ws.info.flags.reading = "1"b;
	     ws.info.read_start = tbuf_num;		/* Save number of first tseg buffer read into. */
	     data_idcw = ws.info.read_idcws (tseg.mode (tbuf_num));
						/* Reading. */
	end;
	if substr (ws.rw_list (1).idcw, 1, 12) ^= substr (data_idcw, 1, 12) then do;
						/* set up DCW list, 1st time */
	     ws.info.flags.large_rec = "0"b;
	     data_size = tseg.buffer_size (tbuf_num);	/* set physical record size */
	     do i = 1 to hbound (ws.rw_list, 1);
		idcwp = addr (ws.rw_list (i).idcw);	/* set up IDCW */
		based_idcw = data_idcw;
		dcwp = addr (ws.rw_list (i).dcw);	/* set up DCW */
		string (dcw) = "0"b;		/* make sure its zero first */
		dcw.address = rel (wbuf_ptr);		/* set relative workspace address */
		dcw.tally = bit (bin (data_size, 12));	/* set tally */
		wbuf_ptr = addrel (wbuf_ptr, data_size);/* increment workspace ptr */
		ws.info.buffer_size (i) = data_size;	/* set up buffer size for reads */
	     end;
	     wbuf_ptr = addr (ws.buffer);		/* reset workspace buffer ptr */
	     tdcwp = addr (ws.mark_tdcw);		/* set up tdcw to chain list */
	     tdcw.address = rel (addr (ws.rw_list (1).idcw));
	     tdcw.type = "10"b;			/* make it a tdcw */
	     tdcw.rel = "1"b;			/* and set relative mode */
	end;
	call METER_IO;				/* go meter the IO time */
	do i = wbuf_num to wbuf_num + op_count - 1;	/* Set up IDCW and and copy data if writing */
	     if tseg.write_sw ^= 0 then do;		/* if writing... */
		data_size = tseg.buffer_size (tbuf_num);/* get buffer size */
		wbuf_ptr -> based_data = ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data;
		wbuf_ptr = addrel (wbuf_ptr, data_size);/* go to next buffer */
		tbuf_num = tbuf_num + 1;		/* increment tseg buffer number */
	     end;
	     idcwp = addr (ws.rw_list (i).idcw);	/* set idcw ptr */
	     idcw.control = "10"b;			/* set all idcws to continue */
	end;
	idcw.control = "00"b;			/* Terminate list with last IDCW. */

	tseg.buffer_count = 0;			/* Tell caller that we picked up all buffers. */
	ws.info.flags.ndtrans = "0"b;			/* These are not non-data transfer commands. */

	if ^ws.info.flags.connected then do;		/* if no I/O in progress, get it going now */
	     call TRY_TO_CONNECT (ws.info.rw_offsetx + ((wbuf_num - 1) * 2));
	     ws.info.flags.connected = "1"b;		/* Connect has been made. */
	end;
	else do;					/* I/O in progress, must be processing markers */
	     if op_count = ws.info.subset_size then do;	/* if we can, set up marker to keep I/O going */
		if tseg.buffer_offset = 0 then	/* if this I/O was for first subset */
		     idcwp = addr (ws.rw_list (hbound (ws.rw_list, 1)).idcw);
						/* set idcw ptr for last idcw */
		else idcwp = addr (ws.rw_list (tseg.buffer_offset).idcw);
						/* otherwise set for middle idcw */
		idcw.control = "11"b;		/* set marker control bits in appropriate idcw */
	     end;
	     call CHECK_STATUS;			/* wait for status to come in */
	     if ^ws.info.flags.connected &		/* if no I/O in progress */
		tseg.completion_status = 1 then do;	/* and no error, get I/O going */
		call TRY_TO_CONNECT (ws.info.rw_offsetx + ((wbuf_num - 1) * 2));
		ws.info.flags.connected = "1"b;	/* Connect has been made. */
	     end;
	end;

     end MARKER_READ_WRITE;
%page;
READ_WRITE:
     procedure;

/*	This procedure is called to set up the IDCWs and DCWs used to read
   *	or write data.  The write switch in the tseg tells us which type
   *	of operation is to be performed.
*/
	op_count = tseg.buffer_count;			/* Get number of buffers to read or write. */
	if op_count > ws.info.subset_size then do;	/* Did caller specify too many buffers? */
	     ecode = error_table_$too_many_buffers;
	     goto INTERNAL_PROC_RETURN;
	end;

	wbuf_ptr = addr (ws.buffer);			/* Get pointer to buffer area in IOI workspace. */
	tbuf_num = tseg.buffer_offset + 1;		/* Get number of first tseg buffer. */
						/* tseg buffer offset starts with 0. */

	if tseg.write_sw ^= 0 then			/* Are we reading or writing? */
	     ws.info.flags.reading = "0"b;		/* Writing not reading. */
	else do;					/* Reading. */
	     ws.info.flags.reading = "1"b;
	     ws.info.read_start = tbuf_num;		/* Save number of first tseg buffer read into. */
	     if tseg.get_size ^= 1 then		/* Does caller want actual data size read? */
		ws.info.flags.get_size = "0"b;	/* No. */
	     else do;				/* Yes. */
		ws.info.flags.get_size = "1"b;
		if op_count > 1 then do;		/* Only works if reading one buffer. */
		     ecode = error_table_$too_many_buffers;
		     goto INTERNAL_PROC_RETURN;
		end;
	     end;
	end;
	call METER_IO;				/* go meter this I/O */
	tot_data_size = 0;				/* Keep count of combined buffer sizes. */
	do i = 1 to op_count;			/* Set up IDCW and DCW for each buffer. */
	     data_size = tseg.buffer_size (tbuf_num);	/* Num of words to process in this buf. */
	     tot_data_size = tot_data_size + data_size;	/* Get total num of words to process. */
	     if (tot_data_size > ws.info.buf_size) | (data_size <= 0) then do;
						/* Is total  more than we can handle? */
						/* Or is number for this buffer invalid? */
		ecode = error_table_$buffer_big;
		goto INTERNAL_PROC_RETURN;
	     end;
	     if data_size > 4096 then			/* If more than one DCW needed ... */
		if op_count > 1 then do;		/* Can only allow one operation. */
		     ecode = error_table_$too_many_buffers;
		     go to INTERNAL_PROC_RETURN;
		end;
		else ws.info.flags.large_rec = "1"b;
	     else ws.info.flags.large_rec = "0"b;

	     idcwp = addr (ws.rw_list (i).idcw);	/* Now set up IDCW. */
	     if tseg.write_sw ^= 0 then do;		/* Are we writing or reading? */
		based_idcw = ws.info.write_idcws (tseg.mode (tbuf_num));
						/* Writing, copy data from tseg to workspace. */
		wbuf_ptr -> based_data = ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data;
	     end;
	     else do;				/* Reading. */
		based_idcw = ws.info.read_idcws (tseg.mode (tbuf_num));
		ws.info.buffer_size (i) = data_size;	/* Remember how many words we are to read. */
	     end;

	     dcwp = addr (ws.rw_list (i).dcw);		/* Set up DCW first. */
	     do while (data_size > 0);		/* Make as many DCWs as needed. */
		string (dcw) = "0"b;
		dcw.address = rel (wbuf_ptr);
		dcw_tally = min (data_size, 4096);
		dcw.tally = bit (bin (dcw_tally, 12));
		if data_size > 4096 then
		     dcw.type = "01"b;
		dcwp = addrel (dcwp, 1);
		wbuf_ptr = addrel (wbuf_ptr, dcw_tally);
		data_size = data_size - dcw_tally;
	     end;

	     tbuf_num = tbuf_num + 1;			/* Move to next tseg buffer. */
	end;
	idcw.control = "00"b;			/* Terminate list with last IDCW. */

	tseg.buffer_count = 0;			/* Tell caller that we picked up all buffers. */
	ws.info.flags.ndtrans = "0"b;			/* These are not non-data transfer commands. */

	call TRY_TO_CONNECT (ws.info.rw_offsetx);
	ws.info.flags.connected = "1"b;		/* Connect has been made. */

     end READ_WRITE;
%page;
/* METER_IO - subroutine to meter time of each I/O */

METER_IO:
     proc;

	if ^display_meters then
	     return;				/* if not doing metering, forget it */
	if ws.last_io_time = 0 then			/* if first I/O... */
	     ws.last_io_time, ws.low_delta = clock ();	/* initialize meters */
	else do;					/* do some metering */
	     io_time = clock ();			/* get the current clock reading */
	     delta = io_time - ws.last_io_time;		/* get time between ios */
	     ws.last_io_time = io_time;		/* save current time */
	     ws.io_delta = ws.io_delta + delta;		/* add in current increment */
	     if delta > ws.high_delta then		/* if this increment is larger than previous.. */
		ws.high_delta = delta;		/* save this one */
	     if delta < ws.low_delta then		/* if this icrement is smaller than previous */
		ws.low_delta = delta;		/* save this one */
	     if tseg.buffer_count > ws.info.block_count then
						/* if block count > whats saved */
		ws.info.block_count = tseg.buffer_count;/* change it */
	     ws.number_ios = ws.number_ios + 1;		/* increment number of data xfer ios */
	end;

     end METER_IO;

/* CHECK_STATUS - subroutine to check status queue. If status queue entry full,
   we will process it without going blocked. */

CHECK_STATUS:
     proc;

	if CK_STATQ () then				/* if there is status to process.. */
	     call PROCESS_QUEUE;			/* go do it, don't wait for it */
	else do;					/* currently no status, drain the channel... */
	     call ipc_$drain_chn (ws.info.wait_list.wait_echan, ecode);
						/* get ride of any pending wakeups */
	     if ecode ^= 0 then do;
		call convert_ipc_code_ (ecode);
		goto INTERNAL_PROC_RETURN;
	     end;
	     if CK_STATQ () then			/* if there is status to process.. */
		call PROCESS_QUEUE;			/* go do it, don't wait for it */
	     else call WAIT_FOR_STATUS;		/* go wait for marker or terminate status */
	end;

     end CHECK_STATUS;
%page;
TRY_TO_CONNECT:
     proc (P_idx);

/* *	This procedure is used to perform connects; if there is insufficient
   *	main memory for a buffer when it is called, it waits for one half second,
   *	and tries again. If it fails after 25 tries, or encounters some other
   *	error, it aborts and goes to INTERNAL_PROC_RETURN. This is done in
   *	tdcm_ because it is necessary to go blocked while waiting; the error
   *	of not having sufficient memory used to crash the system. */

dcl      P_idx		  fixed bin parameter;
dcl      connect_retries	  fixed bin;
dcl      MAX_CONNECT_RETRIES	  fixed bin internal static options (constant) init (25);

	connect_retries = 0;			/* haven't tried at all yet */

TRY_AGAIN_TO_CONNECT:
	call ioi_$connect (ws.info.ioix, P_idx, ecode);

	if ecode = 0 then
	     return;				/* successfully accomplished */
	else if ecode ^= error_table_$out_of_main_memory then
						/* lossage, some unexpected error */
	     goto INTERNAL_PROC_RETURN;
	else do;					/* not enough room now, wait a while */
	     if connect_retries > MAX_CONNECT_RETRIES then/* we've tried too often, let's just give up */
		goto INTERNAL_PROC_RETURN;
	     connect_retries = connect_retries + 1;

	     call WAIT_FOR_A_MOMENT ();

	     goto TRY_AGAIN_TO_CONNECT;
	end;					/* end of loop trying to connect */

     end TRY_TO_CONNECT;
%page;
WAIT_FOR_A_MOMENT:
     proc ();

/* *	This procedure is used to sleep for a short period of time, while
   *	waiting for more buffer space to become available. It is stolen
   *	more or less bodily from set_lock_. */

dcl      ALRM_STRING	  (1) char (32) internal static options (constant) init ("alrm");
dcl      A_BRIEF_MOMENT	  fixed bin (71) internal static options (constant) init (500000);
						/* half a second, really */
dcl      RELATIVE_MICROSECONDS  bit (2) aligned internal static options (constant) init ("10"b);

dcl      initialized_for_waiting
			  bit (1) aligned internal static init ("0"b);
dcl      this_is_initial_ring	  bit (1) aligned internal static;
dcl      alrm_mask		  bit (36) aligned internal static;
dcl      1 wait_list	  aligned internal static,
	 2 count		  fixed bin,
	 2 channel	  fixed bin (71);
dcl      saved_alarm_channel	  fixed bin (71);
dcl      saved_alarm_time	  fixed bin (71);
dcl      ignore_message	  fixed bin (71);
dcl      saved_mask		  bit (36) aligned;

dcl      create_ips_mask_	  entry (ptr, fixed bin, bit (36) aligned);
dcl      get_lock_id_	  ext entry (bit (36) aligned);
dcl      get_ring_		  ext entry returns (fixed bin (3));
dcl      get_initial_ring_	  ext entry returns (fixed bin (3));
dcl      hcs_$get_alarm_timer	  ext entry (fixed bin (71), fixed bin (71));
dcl      hcs_$get_ips_mask	  entry (bit (36) aligned);
dcl      hcs_$set_alarm_timer	  ext entry (fixed bin (71), fixed bin, fixed bin (71));
dcl      ipc_$create_ev_chn	  ext entry (fixed bin (71), fixed bin (35));
dcl      ipc_$block		  ext entry (ptr, ptr, fixed bin (35));
dcl      timer_manager_$sleep	  ext entry (fixed bin (71), bit (2) aligned);


	if ^initialized_for_waiting then do;		/* prepare to wait for a moment */
	     call create_ips_mask_ (addr (ALRM_STRING), 1, alrm_mask);
	     alrm_mask = substr (^alrm_mask, 1, 35);	/* complement it for later tests */
	     this_is_initial_ring = (get_ring_ () = get_initial_ring_ ());
	     call ipc_$create_ev_chn (wait_list.channel, (0));
	     wait_list.count = 1;
	     initialized_for_waiting = "1"b;
	end;

	call hcs_$get_ips_mask (saved_mask);		/* See if IPS are masked. */
	if this_is_initial_ring & ((substr (saved_mask, 1, 35) & alrm_mask) = alrm_mask) then do;
						/* we can call timer_manager_ */
	     call timer_manager_$sleep (A_BRIEF_MOMENT, RELATIVE_MICROSECONDS);
	end;					/* sleep for a moment */

	else do;					/* we cannot call timer_manager_ */
	     call hcs_$get_alarm_timer (saved_alarm_time, saved_alarm_channel);
						/* remember current alarm settings */
	     call hcs_$set_alarm_timer (A_BRIEF_MOMENT, 1, wait_list.channel);
						/* get awakened later */
	     call ipc_$block (addr (wait_list), addr (ignore_message), ecode);
						/* wait for wakeup */
	     call hcs_$set_alarm_timer (saved_alarm_time, 2, saved_alarm_channel);
						/* reset original timer settings */
	     if ecode ^= 0 then			/* if trouble then give up */
		goto INTERNAL_PROC_RETURN;
	end;

	return;					/* we have waited */
     end;						/* internal procedure WAIT_FOR_A_MOMENT */
%page;
REWIND_TAPE:
     procedure;

/*	Temporary procedure used with the dummy version of RCP.
*/
dcl      tdcm_$tdcm_iocall	  entry (ptr, fixed bin (35));

	tseg.sync = 1;
	tseg.get_size = 0;
	tseg.buffer_count = 0;
	tseg.command_count = 1;
	tseg.command_queue (1) = 111000b;		/* REWIND */

	call tdcm_$tdcm_iocall (tsegp, ecode);

     end REWIND_TAPE;

     end tdcm_;




		    tdcm_attach_.pl1                11/30/82  1535.7rew 11/30/82  1207.7       40302



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tdcm_attach_:
     procedure (arg_tsegp, arg_ecode);

/*	This program implements the entry point tdcm_$tdcm_attach.
   *	Created on 02/20/75 by Bill Silver.
   *	Modified 7/79 by R.J.C. Kissel to use version 1 tseg.
   *
   *	This program is called by tdcm_ to attach a tape drive.  No concept of
   *	privilege is recognized.  RCP will determine the privilege of the caller.
   *	Since at this time we do not know the name of the tape reel the caller
   *	wants mounted we will not be able to call RCP to make the attachment.
   *	The actual attachment will be made by tdcm_$tdcm_message_.  We will use the
   *	first tseg buffer for a temporary IOI workspace.  We will return a 0 in the
   *	tseg drive_number field.  Thus the tseg will be in an inconsistent state
   *	until the first call to tdcm_$tdcm_message.
*/

dcl      arg_ecode		  fixed bin (35);		/* (O) Standard error_table_ code. */
dcl      arg_tsegp		  ptr;			/* (I) Pointer to user's tseg. */

dcl      ecode		  fixed bin (35);		/* Temporary error code. */

dcl      init_flag		  bit (1) internal static init ("0"b);

dcl      based_ws_info	  (size (ws_info)) bit (36) based (ws_ptr);

dcl      (addr, size, string)	  builtin;

dcl      default_buf_size	  fixed bin /* tdcm_ I/O buffer size.  Room for 2 MST records. */ internal static
			  init (2080);

dcl      convert_ipc_code_	  entry (fixed bin (35));
dcl      hcs_$assign_channel	  entry (fixed bin (71), fixed bin (35));
dcl      ipc_$create_ev_chn	  entry (fixed bin (71), fixed bin (35));
dcl      tdcm_detach_	  entry (ptr, fixed bin (35));
dcl      error_table_$unimplemented_version
			  fixed bin (35) external;	/*						*/
%include tseg;
/**/
%include tdcm_info;
/**/
%include ioi_stat;
/**/
	tsegp = arg_tsegp;				/* Pick up argument. */

	if tseg.version_num ^= tseg_version_2 then do;
	     arg_ecode = error_table_$unimplemented_version;
	     return;
	end;

	tseg.ws_segno = "0"b;			/* We don't have a real IOI workspace yet. */
	ws_ptr = addr (tseg.buffer (1));		/* Use first buffer for temp workspace. */
	string (based_ws_info) = "0"b;		/* Initialize all info fields to zero. */

/*	We must set up three event channels.
   *	1.  A user event channel - found in the tseg.
   *	2.  A fast event channel - used to wait for status.
   *	3.  A call event channel - used to handle special interrupts.
*/
	ws.info.wait_list.num_ev_chans = 1;		/* Set up the wait list count. */
	ws.info.user_echan = tseg.ev_chan;		/* Get event channel ID from tseg. */

/* Created our main (fast) event channel. */
	call hcs_$assign_channel (ws.info.fast_echan, ecode);
	if ecode ^= 0				/* Did we get a fast channel? */
	then do;					/* No, get regular channel. */
	     call ipc_$create_ev_chn (ws.info.fast_echan, ecode);
	     if ecode ^= 0 then do;
		call convert_ipc_code_ (ecode);
		goto RETURN;
	     end;
	end;
	ws.info.detachx = 1;			/* Note that fast channel was created OK. */
	ws.info.init_echan = ws.info.fast_echan;	/* Start out using the fast channel. */

/* Create a regular event channel for special interrupts. */
	call ipc_$create_ev_chn (ws.info.special_echan, ecode);
	if ecode ^= 0				/* When drive attached it becomes a call channel. */
	then do;
	     call convert_ipc_code_ (ecode);
	     goto RETURN;
	end;
	ws.info.detachx = 2;			/* Note that this channel was created OK. */

/*	Now initialize some fields in the temporary workspace.  They will
   *	be copied into the real workspace when we get one.
*/
	ws.info.buf_size = default_buf_size;		/* Set up size of tdcm_ I/O buffer. */
	if tseg.tracks = 1				/* Save requested track type. */
	then ws.info.tracks = 7;			/* 1 => seven track. */
	else ws.info.tracks = 9;			/* Otherwise it is nine track. */
	tseg.drive_name = "";			/* Don't let caller think it has a real drive. */

RETURN:
	arg_ecode = ecode;
	if ecode ^= 0				/* Was there any error? */
	then call tdcm_detach_ (ws_ptr, ecode);

     end tdcm_attach_;




		    tdcm_detach_.pl1                11/30/82  1535.7rew 11/30/82  1207.8       24363



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


tdcm_detach_:  procedure  (arg_ws_ptr, arg_ecode);

/*	This program implements the tdcm_$tdcm_detach entry point.
*	Created on 02/20/75 by Bill Silver.
*
*	This program is called to detach the specified tape drive.
*	Unless the current disposition specifies that we should retain
*	this tape drive assignmnet we will unassign as well as detach
*	this tape drive.
*/

/*		ARGUMENT  DATA		*/

dcl	arg_ecode		fixed bin(35);	/* (O) Standard error_table_ code. */
dcl	arg_ws_ptr	ptr;		/* (I) Pointer to IOI workspace segment. */


/*		AUTOMATIC  DATA		*/

dcl	drive_num		fixed bin;	/* Number of the current drive. */
dcl	ecode		fixed bin(35);	/* Temporary error code. */
dcl	save_ecode	fixed bin;	/* Used to save ecode. */
dcl	special_echan	fixed bin(71);	/* Copied from workspace. */
dcl	fast_echan	fixed bin(71);


/*		EXTERNAL ENTRIES CALLED	*/

dcl     (	addr, size, string )  builtin;

dcl	convert_ipc_code_	entry  (fixed bin(35));
dcl	ipc_$delete_ev_chn	entry  (fixed bin(71), fixed bin(35));
dcl	rcp_$detach	entry  (bit(36) aligned, bit(*) aligned, fixed bin, char(*), fixed bin(35));
/*	*/
%include tdcm_info;
/*	*/
%include ioi_stat;
/*	*/
/*	Begin tdcm_detach_.pl1
*/
	ws_ptr = arg_ws_ptr;		/* Copy arguments. */

	special_echan = ws.info.special_echan;	/* Copy before workspace deleted. */
	fast_echan = ws.info.fast_echan;
	save_ecode = 0;

	goto DETACH(ws.info.detachx);		/* Go undo whatever has been done. */

DETACH(3):				/* Tape drive has been attached. */
	call rcp_$detach (ws.info.rcp_id, ws.info.disposition, ws.info.error_count, "", ecode);
	if   ecode ^= 0
	     then if   save_ecode = 0
		     then save_ecode = ecode;

DETACH(2):				/* Special event channel was created. */
	call ipc_$delete_ev_chn (special_echan, ecode);
	if   ecode ^= 0
	     then do;
		call convert_ipc_code_ (ecode);
		if   save_ecode = 0
		     then save_ecode = ecode;
	     end;

DETACH(1):				/* Fast event channel was created. */
	call ipc_$delete_ev_chn (fast_echan, ecode);
	if   ecode ^= 0
	     then do;
		call convert_ipc_code_ (ecode);
		if   save_ecode = 0
	 	     then save_ecode = ecode;
	     end;

DETACH(0):
	arg_ecode = save_ecode;		/* Return first error code. */

	end  tdcm_detach_;




		    tdcm_message_.pl1               11/30/82  1535.7rew 11/30/82  1207.8      140499



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


/* format: style4,delnl,insnl,indattr,ifthen,dclind9 */
tdcm_message_:
     procedure (arg_tsegp, arg_ws_ptr, arg_reel_name, arg_write_sw, arg_ecode);

/*	This program implements the tdcm_$tdcm_message entry point.
   *	Created on 02/20/75 by Bill Silver.
   *	Cleanup handler during block added 12/28/76 by Bernard Greenberg.
   *	Modified on 09/19/77 by R.J.C. Kissel to fix bug in call to ipc_$decl_ev_call_chn.
   *	Modified on 12/09/78 by Michael R. Jordan to use version 2 tape_info.
   *	Modified 3/79 by Michael R. Jordan for MR7.0R to stop using rcp_$tape_message and always detach (with retain)
   *	  and re-attach for multiple volumes.
   *	Modified 7/79 by R.J.C. Kissel to use tseg version 1, to correct wrong drive name bug,
   *	     and to ask RCP for the right density.
   *
   *      Modified 8/80 by R.L. Coppola to pass tseg.drive_name to tape_info.device_name.
   *
   *	This program is called to write a mount message on the operator's console.
   *	However, the first time it is called no message is written.  Instead this
   *	first call will actually perform the tape drive attachment.  For at least
   *	a while, subsequent calls will result in a mount message being typed.
*/

/*		ARGUMENTS  DATA		*/

dcl      arg_ecode		  fixed bin (35);		/* (O) Standard error_table_ code. */
dcl      arg_reel_name	  char (*);		/* (I) Tape reel ID name plus qualifiers. */
dcl      arg_tsegp		  ptr;			/* (I) Pointer to user's tseg. */
dcl      arg_write_sw	  fixed bin (1);		/* (I) 1 => write, 0 => read. */
dcl      arg_ws_ptr		  ptr;			/* (I) Pointer to temporary workspace. */


/*		AUTOMATIC  DATA		*/

dcl      1 tape_info_buffer	  like tape_info;		/* Tape info structure needed by RCP. */

dcl      temp_idcw		  bit (36) aligned;		/* Used to build read/write IDCW's. */
dcl      system_flag	  bit (1);		/* ON => user wants to be a system process. */
dcl      write_flag		  bit (1);		/* Used to copy arg_write_sw. */

dcl      comment		  char (64);		/* Comment sent to RCP. */
dcl      reel_name		  char (32);		/* Tape reel ID name. */
dcl      temp_reel_name	  char (64);		/* Used to copy reel name argument. */

dcl      real_ws_ptr	  ptr;			/* Pointer to actual IOI workspace segment. */

dcl      delimx		  fixed bin;		/* Used to parse the reel name string. */
dcl      drive_num		  fixed bin;		/* Number of the current drive. */
dcl      ecode		  fixed bin (35);		/* Temporary error code. */
dcl      i		  fixed bin;
dcl      statex		  fixed bin;		/* RCP state index. */
dcl      timeout_max	  fixed bin (71);		/* Maximum time-out interval. */
dcl      workspace_max	  fixed bin (19);		/* Maximum size of IOI workspace. */
dcl      workspace_size	  fixed bin (19);		/* Actual size of IOI workspace. */


/*		BASED  DATA		*/

dcl      based_idcw		  bit (36) based (idcwp) aligned;

dcl      event_data		  (8) bit (36);		/* Not really used. */


/*		INTERNAL STATIC DATA	*/

dcl      read_idcw_commands	  (0:5) bit (6) internal static init ("000101"b,
						/* Binary */
			  "000100"b,		/* BCD */
			  "000011"b,		/* 9 Track */
			  "010100"b,		/* EBCDIC */
			  "010111"b,		/* ASCII */
			  "010101"b);		/* ASCII/EBCDIC */

dcl      write_idcw_commands	  (0:5) bit (6) internal static init ("001101"b,
						/* Binary */
			  "001100"b,		/* BCD */
			  "001011"b,		/* 9 Track */
			  "011100"b,		/* EBCDIC */
			  "011111"b,		/* ASCII */
			  "011101"b);		/* ASCII/EBCDIC */


/*		EXTERNAL ENTRIES CALLED	*/

dcl      (addr, after, baseno, bit, decat, fixed, hbound, index, rel, rtrim, size, string, substr, unspec)
			  builtin;

dcl      error_table_$ionmat	  fixed bin (35) external;
dcl      error_table_$big_ws_req
			  fixed bin (35) external;
dcl      error_table_$unimplemented_version
			  fixed bin (35) external;

dcl      com_err_		  entry options (variable);
dcl      convert_ipc_code_	  entry (fixed bin (35));
dcl      cv_dec_		  entry (char (*), fixed bin);
dcl      get_process_id_	  entry returns (bit (36) aligned);
dcl      hcs_$wakeup	  entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35));
dcl      ioi_$set_event	  entry (fixed bin, fixed bin (71), fixed bin (35));
dcl      ioi_$set_status	  entry (fixed bin, fixed bin (18), fixed bin, fixed bin (35));
dcl      ioi_$timeout	  entry (fixed bin, fixed bin (71), fixed bin (35));
dcl      ioi_$workspace	  entry (fixed bin, ptr, fixed bin (19), fixed bin (35));
dcl      ipc_$block		  entry (ptr, ptr, fixed bin (35));
dcl      ipc_$decl_ev_call_chn  entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35));
dcl      ipc_$decl_ev_wait_chn  entry (fixed bin (71), fixed bin (35));
dcl      rcp_$attach	  entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35));
dcl      rcp_$check_attach	  entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71),
			  fixed bin, fixed bin (35));
dcl      rcp_$detach	  entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35));
dcl      tdcm_$special_handler  entry (ptr);

/*		CONDITIONS		*/

dcl      cleanup		  condition;

%include tseg;

%include tdcm_info;

%include ioi_stat;

%include rcp_tape_info;

%include rcp_resource_types;

%include iom_pcw;

	tsegp = arg_tsegp;				/* Copy arguments. */

	if tseg.version_num ^= tseg_version_2 then do;
	     arg_ecode = error_table_$unimplemented_version;
	     return;
	end;

	ws_ptr = arg_ws_ptr;
	temp_reel_name = arg_reel_name;
	write_flag = bit (arg_write_sw);
	system_flag = "0"b;				/* Assume not a system process. */

	begin;					/* Necessary for multi-volume switching. */

dcl      garbage		  (size (ws)) bit (36);



	     if ws.flags.attached			/* Is tape drive already attached. */
	     then do;				/* Yes, actually process the message. */
		unspec (garbage) = unspec (ws);	/* Make temp copy of workspace. */
		tseg.ws_segno = "0"b;		/* No workspace for a while. */
		ws_ptr = addr (garbage);		/* And start to use it. */
		call rcp_$detach (ws.info.rcp_id, "1"b, ws.info.error_count, "", ecode);
		ws.info.error_count = 0;
		call ipc_$decl_ev_wait_chn (ws.info.special_echan, ecode);
		if ecode ^= 0			/* Did we make it a call channel? */
		then do;				/* No. */
		     call convert_ipc_code_ (ecode);
		     goto RETURN;
		end;
	     end;

/* Now we will parse the reel name string. */
	     delimx = index (temp_reel_name, ",");	/* Look for first comma in reel name. */
	     if delimx = 0				/* Are there other fields in the reel name? */
	     then do;				/* No. */
		reel_name = temp_reel_name;		/* Use the whole reel name. */
		comment = "";			/* No comment. */
	     end;
	     else do;				/* Yes there are other fields in the reel name. */
		reel_name = substr (temp_reel_name, 1, (delimx - 1));
		comment = temp_reel_name;		/* Use whole reel name string as a comment. */
		delimx = index (temp_reel_name, ",sys");
		if delimx ^= 0			/* ",sys" => user wants to be a system process */
		then system_flag = "1"b;
	     end;


/*	Now that we know the reel name we will try to attach the tape drive.
   *	RCP will assign a tape drive depending upon the data in tape_info.
   *	RCP will mount the specified reel on the assigned drive as part of
   *	the attachment.  RCP will make sure that the drive is ready and the
   *	reel is at BOT.  It will make sure that the write ring is correct.
   *	First we must fill in the tape_info structure needed by RCP.
*/
	     tape_info_ptr = addr (tape_info_buffer);	/* Pointer to tape_info structure. */
	     tape_info.version_num = tape_info_version_2; /* We must always set this. */
	     tape_info.usage_time,			/* These fields not used yet. */
		tape_info.wait_time = 0;
	     tape_info.system_flag = system_flag;
	     tape_info.device_name = tseg.drive_name;	/* Assign the right device. */
	     tape_info.model = 0;			/* We will accept any model. */
	     tape_info.tracks = ws.info.tracks;		/* We want specific track type. */
	     tape_info.density = tseg.density;		/* Ask for what the user requested. */
	     tape_info.speed = tseg.speed;
	     tape_info.unused_qualifier = "0"b;
	     tape_info.volume_name = reel_name;		/* Fill in tape info colume data. */
	     tape_info.write_flag = write_flag;
	     tape_info.position_index = 0;		/* Initialize.  Not really used yet. */

/* Use regular channel with RCP.  Not a call chan yet. */
	     ws.info.wait_list.wait_echan = ws.info.special_echan;
	     call rcp_$attach (DEVICE_TYPE (TAPE_DRIVE_DTYPEX), tape_info_ptr, ws.info.special_echan, comment,
		ws.info.rcp_id, ecode);
	     if ecode ^= 0 then
		goto RETURN;

	     reel_name = tape_info.volume_name;		/* remember, these things might have been changed by ring 1 */

	     if index (temp_reel_name, ",") > 0 then
		temp_reel_name = rtrim (reel_name) || "," || after (temp_reel_name, ",");
	     else temp_reel_name = reel_name;

	     arg_reel_name = temp_reel_name;

	     ws.info.detachx = 3;			/* Now we have an RCP ID and must detach. */

/*	We must check to see if the attachment has completed.  If RCP tells us
   *	that there is a short wait we will block.  We must call RCP again after
   *	each short wait.
*/
ATTACH_LOOP:
	     comment = " ";
	     call rcp_$check_attach (ws.info.rcp_id, tape_info_ptr, comment, ws.info.ioix, workspace_max, timeout_max,
		statex, ecode);
	     if comment ^= " "			/* Is there a comment from RCP? */
	     then call com_err_ (0, "tdcm_", "RCP comment: ^a", comment);
	     goto ATTACH_STATE (statex);

ATTACH_STATE (1):					/* Short wait. */
	     on cleanup call clean_up;
	     call ipc_$block (addr (ws.info.wait_list), addr (event_data), ecode);
	     revert cleanup;
	     if ecode ^= 0 then do;
		call convert_ipc_code_ (ecode);
		goto RETURN;
	     end;
	     goto ATTACH_LOOP;			/* Call RCP again. */

ATTACH_STATE (2):					/* Long wait. */
	     ecode = error_table_$ionmat;
ATTACH_STATE (3):					/* Fatal error. */
	     goto RETURN;

/*	The attachment has completed.  We must call IOI to establish the
   *	real IOI workspace buffer.
*/
ATTACH_STATE (0):					/* Attachment complete. */
	     call cv_dec_ (substr (tape_info.device_name, 6, 2), drive_num);
	     tseg.drive_name = tape_info.device_name;	/* Return correct drive name. */

/*	Now we must get a real IOI workspace.  We will ask for a workspace that is
   *	just large enough to contain all of tdcm_info.  If the buffer size is too
   *	large we will have to adjust it so it will fit into the maximum size
   *	workspace that we may allocate.
*/
	     workspace_size = fixed (rel (addr (ws.buf_end)), 18) - fixed (rel (addr (ws.info)), 18) + 1;
	     if workspace_size > workspace_max		/* If buffer size too large adjust it. */
	     then do;
		ws.info.flags.good_ws = "0"b;
		ecode = error_table_$big_ws_req;
		goto RETURN;
	     end;

	     call ioi_$workspace (ws.info.ioix, real_ws_ptr, workspace_size, ecode);
	     if ecode ^= 0 then do;
		ws.info.flags.good_ws = "0"b;
		goto RETURN;
	     end;

	     ws.info.flags.good_ws = "1"b;

/*	We now have a real IOI workspace.  We will copy all workspace ws_info
   *	from the temporary workspace into the real workspace.  From then on
   *	we will deal only with the real workspace.
*/
	     real_ws_ptr -> ws.info = ws_ptr -> ws.info;	/* Move ws_info to real workspace. */
	     ws_ptr = real_ws_ptr;			/* Use real workspace pointer. */
	     tseg.ws_segno = baseno (ws_ptr);		/* Save workspace segment number. */

	end;					/* End of the begin block. */

/*	Now we will complete the initialization of the IOI workspace.
   *	We will call IOI to set the time-out limit to the maximum.
   *	We will convert the special event channel into an event call
   *	channel.  The data pointer for this call channel is the pointer
   *	to the real workspace for this drive.  We must call IOI to set up
   *	the event channel that we want to use when we start I/O processing.
   *	We will initialize all the other data in the workspace including
   *	the DCW lists.
*/
	call ioi_$timeout (ws.info.ioix, timeout_max, ecode);
	if ecode ^= 0 then
	     goto RETURN;

/* Set up our IOI status queue. */
	call ioi_$set_status (ws.info.ioix, fixed (rel (addr (ws.statq)), 18), hbound (ws.statq, 1), ecode);
	if ecode ^= 0 then
	     return;

	do i = 1 to hbound (ws.statq, 1);		/* Set up all status queue entries. */
	     ws.statq (i).completion.st = "0"b;		/* Make this entry free. */
	end;
	ws.info.statqx = 1;				/* Start with first status queue entry. */

	call ioi_$set_event (ws.info.ioix, ws.info.init_echan, ecode);
	if ecode ^= 0				/* Did we set up IOI's event channel? */
	then goto RETURN;				/* No. */

/* From now on always wait on fast channel. */
	ws.info.wait_list.wait_echan = ws.info.fast_echan;

/* Make special channel an event call channel. */
	call ipc_$decl_ev_call_chn (ws.info.special_echan, tdcm_$special_handler, ws_ptr, 0, ecode);
	if ecode ^= 0				/* Did we make it a call channel? */
	then do;					/* No. */
	     call convert_ipc_code_ (ecode);
	     goto RETURN;
	end;

	ws.info.disposition = "0"b;			/* Until told otherwise let RCP decide. */
	ws.info.process_id = get_process_id_ ();	/* Need process ID to wakeup user. */
	ws.info.flags.attached = "1"b;		/* Device is now attached. */

/* Save offset of each DCW list. */
	ws.info.ndt_offsetx = fixed (rel (addr (ws.ndt_list)), 18);
	ws.info.rw_offsetx = fixed (rel (addr (ws.rw_list)), 18);

	do i = 1 to hbound (ws.ndt_list, 1);		/* Initialize non-data transfer IDCWs. */
	     idcwp = addr (ws.ndt_list (i).idcw);	/* Get pointer to IDCW. */
	     string (idcw) = "0"b;			/* Clear it to all zeros. */
	     idcw.device = bit (fixed (drive_num, 6));	/* Set up device number. */
	     idcw.code = "111"b;			/* This => it is an IDCW. */
	     idcw.chan_cmd = "000010"b;		/* This => it is a non-data transfer IDCW. */
	     idcw.count = "000001"b;			/* Record count = 1. */
	end;

	do i = 1 to hbound (ws.rw_list, 1);		/* Set up read/write DCW list. */
	     ws.rw_list (i).dcw = "0"b;		/* Clear all DCW's. */
	end;

	idcwp = addr (temp_idcw);			/* Initialize our work IDCW. */
	string (idcw) = "0"b;			/* Clear it to all zeros. */
	idcw.device = bit (fixed (drive_num, 6));	/* Fill in this drive number. */
	idcw.code = "111"b;				/* This is an IDCW. */
	idcw.control = "10"b;			/* Initialize to continue. */

	do i = 0 to hbound (ws.info.read_idcws, 1);
	     idcwp = addr (ws.info.read_idcws (i));	/* Set up each read IDCW. */
	     based_idcw = temp_idcw;			/* Copy template with drive number. */
	     idcw.command = read_idcw_commands (i);	/* Fill in corresponding command. */
	end;

	do i = 0 to hbound (ws.info.write_idcws, 1);
	     idcwp = addr (ws.info.write_idcws (i));	/* Set up each write IDCW. */
	     based_idcw = temp_idcw;
	     idcw.command = write_idcw_commands (i);
	end;

/*	Now send a wakeup to the user.  He should be waiting for it.
   *	It tells him that the tape drive is now in READY.
*/
	call hcs_$wakeup (ws.info.process_id, ws.info.user_echan, 0, ecode);

RETURN:
	arg_ecode = ecode;				/* Return error code. */

	return;


/* Clean-up procedure during blocking. */

clean_up:
     proc;

	call rcp_$detach (ws.info.rcp_id, "0"b, (0), "", (0));

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