



		    fort_bfp_builtins_.fortran      01/10/85  1316.0rew 01/10/85  1306.2       46998



c ******************************************
c *                                        *
c * Copyright, (C) Honeywell Limited, 1984 *
c *                                        *
c ******************************************

      %global ansi77, bfp
      real function abs_(arg)
      real arg
      abs_ = abs(arg)
      end
      real function acos_(arg)
      real arg
      acos_ = acos(arg)
      end
      real function aimag_(arg)
      complex arg
      aimag_ = aimag(arg)
      end
      real function aint_(arg)
      real arg
      aint_ = aint(arg)
      end
      real function amod_(arg1, arg2)
      real arg1, arg2
      amod_ = amod(arg1, arg2)
      end
      real function anint_(arg)
      real arg
      anint_ = anint(arg)
      end
      real function asin_(arg)
      real arg
      asin_ = asin(arg)
      end
      real function atan2_(arg1, arg2)
      real arg1, arg2
      atan2_ = atan2(arg1, arg2)
      end
      real function atan_(arg)
      real arg
      atan_ = atan(arg)
      end
      real function cabs_(arg)
      complex arg
      cabs_ = cabs(arg)
      end
      complex function ccos_(arg)
      complex arg
      ccos_ = ccos(arg)
      end
      complex function cexp_(arg)
      complex arg
      cexp_ = cexp(arg)
      end
      complex function clog_(arg)
      complex arg
      clog_ = clog(arg)
      end
      complex function conjg_(arg)
      complex arg
      conjg_ = conjg(arg)
      end
      real function cos_(arg)
      real arg
      cos_ = cos(arg)
      end
      real function cosh_(arg)
      real arg
      cosh_ = cosh(arg)
      end
      complex function csin_(arg)
      complex arg
      csin_ = csin(arg)
      end
      complex function csqrt_(arg)
      complex arg
      csqrt_ = csqrt(arg)
      end
      complex function cxp2_(arg1, arg2)
      complex arg1, arg2
      cxp2_ = arg1**arg2
      end
      double precision function dabs_(arg)
      double precision arg
      dabs_ = dabs(arg)
      end
      double precision function dacos_(arg)
      double precision arg
      dacos_ = dacos(arg)
      end
      double precision function dasin_(arg)
      double precision arg
      dasin_ = dasin(arg)
      end
      double precision function datan2_(arg1, arg2)
      double precision arg1, arg2
      datan2_ = datan2(arg1, arg2)
      end
      double precision function datan_(arg)
      double precision arg
      datan_ = datan(arg)
      end
      double precision function dcos_(arg)
      double precision arg
      dcos_ = dcos(arg)
      end
      double precision function dcosh_(arg)
      double precision arg
      dcosh_ = dcosh(arg)
      end
      double precision function ddim_(arg1, arg2)
      double precision arg1, arg2
      ddim_ = ddim(arg1, arg2)
      end
      double precision function dexp_(arg)
      double precision arg
      dexp_ = exp(arg)
      end
      real function dim_(arg1, arg2)
      real arg1, arg2
      dim_ = dim(arg1, arg2)
      end
      double precision function dint_(arg)
      double precision arg
      dint_ = dint(arg)
      end
      double precision function dlog10_(arg)
      double precision arg
      dlog10_ = dlog10(arg)
      end
      double precision function dlog_(arg)
      double precision arg
      dlog_ = dlog(arg)
      end
      double precision function dmod_(arg1, arg2)
      double precision arg1, arg2
      dmod_ = dmod(arg1, arg2)
      end
      double precision function dnint_(arg)
      double precision arg
      dnint_ = dnint(arg)
      end
      double precision function dprod_(arg1, arg2)
      real arg1, arg2
      dprod_ = dprod(arg1, arg2)
      end
      double precision function dsign_(arg1, arg2)
      double precision arg1, arg2
      dsign_ = dsign(arg1, arg2)
      end
      double precision function dsin_(arg)
      double precision arg
      dsin_ = dsin(arg)
      end
      double precision function dsinh_(arg)
      double precision arg
      dsinh_ = dsinh(arg)
      end
      double precision function dsqrt_(arg)
      double precision arg
      dsqrt_ = dsqrt(arg)
      end
      double precision function dtan_(arg)
      double precision arg
      dtan_ = dtan(arg)
      end
      double precision function dtanh_(arg)
      double precision arg
      dtanh_ = dtanh(arg)
      end
      real function exp_(arg)
      real arg
      exp_ = exp(arg)
      end
      integer function idnint_(arg)
      double precision arg
      idnint_ = idnint(arg)
      end
      real function alog10_(arg)
      real arg
      alog10_ = log10(arg)
      end
      real function alog_(arg)
      real arg
      alog_ = log(arg)
      end
      integer function nint_(arg)
      real arg
      nint_ = nint(arg)
      end
      real function sign_(arg1, arg2)
      real arg1, arg2
      sign_ = sign(arg1, arg2)
      end
      real function sin_(arg)
      real arg
      sin_ = sin(arg)
      end
      real function sinh_(arg)
      real arg
      sinh_ = sinh(arg)
      end
      real function sqrt_(arg)
      real arg
      sqrt_ = sqrt(arg)
      end
      real function tan_(arg)
      real arg
      tan_ = tan(arg)
      end
      real function tanh_(arg)
      real arg
      tanh_ = tanh(arg)
      end




		    fort_cleanup_.pl1               12/27/84  0853.8rew 12/27/84  0838.6       20880



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

/* format: style3,^delnl,linecom */
fort_cleanup_:
     proc (dp1, dc1, dp2, dp3, db1, sp);

/* This procedure is the cleanup controller for Fortran Large and Very Large
   arrays, and for fortran_io_ cleanup.  It is called by 'unwind_stack_' when
   'cleanup' is signaled to a fortran program. */

/* Modification History.

   Created:	August 30, 1982 by Tom Oke (UNCA). 

   Modified: 15 Novemeber 1982, TO - Change to 'fortran_storage_' and
	'fortran_storage_manager_' from 'fsd_' and 'fsm_'.
*/

/* SPECIAL ENTRY CONDITIONS REQUIRED FROM 'unwind_stack_'. */

/* 'unwind_stack_' uses an entry variable in which the label has been set to
   this routine, and the descripter pointer is set to the stack pointer
   of the frame in which the cleanup handler exists.  If this stack pointer
   functionality is changed then we have no way of knowing what the stack
   frame pointer is to do the cleanup with.

   The unwind_stack_ definition is:
dcl  entry_variable variable entry (ptr, char (*), ptr, ptr, bit (1) aligned);

   By adding an additional pointer to the expected parameters, we can find
   the address of this pointer (the argument block pointer) and thus find the
   stack pointer value left by unwind_stack_.  A bit kludgy, but functional and
   fast.
*/

dcl	(dp1, dp2, dp3)	ptr;			/* Dummy Pointers */
dcl	dc1		char (*);			/* Dummy Characters */
dcl	db1		bit (1) aligned;		/* Dummy bit */

dcl	sp		ptr;			/* stack pointer deferred */

dcl	fortran_storage_manager_$free
			entry (ptr);		/* Passed 'owning' stack ptr */


/* Find the stack frame pointer of the cleanup handler, then pass it to both
   the fortran_storage_manager_$free entry to free up Large and Very Large
   Arrays, and to fortran_io_$cleanup to free up files associated with that
   level. */


	call fortran_storage_manager_$free (addr (sp));

     end fort_cleanup_;




		    fort_hfp_builtins_.fortran      01/10/85  1316.0rew 01/10/85  1306.2       91701



c ******************************************
c *                                        *
c * Copyright, (C) Honeywell Limited, 1984 *
c *                                        *
c ******************************************

      %global ansi77, hfp
      real function abs_(arg)
      real arg
      abs_ = abs(arg)
      end
      real function acos_(arg)
      real arg
      acos_ = acos(arg)
      end
      real function aimag_(arg)
      complex arg
      aimag_ = aimag(arg)
      end
      real function aint_(arg)
      real arg
      aint_ = aint(arg)
      end
      real function amod_(arg1, arg2)
      real arg1, arg2
      amod_ = amod(arg1, arg2)
      end
      real function anint_(arg)
      real arg
      anint_ = anint(arg)
      end
      real function asin_(arg)
      real arg
      asin_ = asin(arg)
      end
      real function atan2_(arg1, arg2)
      real arg1, arg2
      atan2_ = atan2(arg1, arg2)
      end
      real function atan_(arg)
      real arg
      atan_ = atan(arg)
      end
      real function cabs_(arg)
      complex arg
      real major, minor, temp
      real max_real, max_real_by_root_2, max_real_by_16
      data max_real/o376777777777/, max_real_by_root_2/o376552023631/,
     &     max_real_by_16/o375777777777/
      major = abs(real(arg))
      minor = abs(aimag(arg))
      if (major.lt.minor) then
         temp = major
         major = minor
         minor = temp
      endif
      if (major.eq.0.0) then
         cabs_ = 0.0
      else if (major.le.max_real_by_root_2) then
         temp = minor/major
         cabs_ = major*sqrt(temp*temp + 1.0)
      else
         temp = minor/major
         temp = 0.0625*major*sqrt(temp*temp + 1.0)
         cabs_ = 16.0*temp
         if (temp.gt.max_real_by_16) cabs_ = max_real
      endif
      end
      complex function ccos_(arg)
      complex arg
      real x, y
      x = real(arg)
      y = aimag(arg)
      ccos_ = cmplx(cos(x)*cosh_(y), -sin(x)*sinh_(y))
      end
      complex function cexp_(arg)
      complex arg
      real x, y
      x = real(arg)
      y = aimag(arg)
      cexp_ = exp(x)*cmplx(cos(y), sin(y))
      end
      complex function clog_(arg)
      complex arg
      real r, x, y
      r = cabs_(arg)
      x = real(arg)
      y = aimag(arg)
      clog_ = cmplx(log(r), atan2(y, x))
      end
      complex function conjg_(arg)
      complex arg
      conjg_ = conjg(arg)
      end
      real function cos_(arg)
      real arg
      cos_ = cos(arg)
      end
      real function cosh_(arg)
      real arg
      real f, max_real, x
      data max_real/o376777777777/
      external signal (descriptors)
      x = abs(arg)
      if (x .gt. 352.8119) then
         call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed.  Type ""start"" to set result to + or - .83798798+153")
         cosh_ = max_real
      else if (x .gt. 9.704) then
         f = exp(0.5*x)
         cosh_ = 0.5*f*f
      else
         f = exp(x)
         cosh_ = 0.5*(f + 1/f)
      endif
      end
      complex function csin_(arg)
      complex arg
      real x, y
      x = real(arg)
      y = aimag(arg)
      csin_ = cmplx(sin(x)*cosh_(y), cos(x)*sinh_(y))
      end
      complex function csqrt_(arg)
      complex arg
      real factor, scaled_r, scaled_x, scaled_y
      if (abs(real(arg)).ge.1 .or. abs(aimag(arg)).ge.1) then
         factor = 4
         scaled_x = 0.03125*real(arg)
         scaled_y = 0.03125*aimag(arg)
      else
         factor = 0.25
         scaled_x = 8*real(arg)
         scaled_y = 8*aimag(arg)
      endif
      scaled_r = cabs_(cmplx(scaled_x, scaled_y))
      csqrt_ = cmplx(factor*sqrt(scaled_r + scaled_x),
     &        sign(factor*sqrt(scaled_r - scaled_x), scaled_y))
      end
      complex function cxp2_(arg1, arg2)
      complex arg1, arg2
      double precision f, x1, x2, x3, x4, y1, y2, y3, y4

c     Set (x1, y1) = arg1 and (x2, y2) = arg2.
      x1 = real(arg1)
      y1 = aimag(arg1)
      x2 = real(arg2)
      y2 = aimag(arg2)

c     Set (x3, y3) = log(arg1).
      x3 = 0.5*dlog(x1*x1 + y1*y1)
      y3 = datan2(y1, x1)

c     Set (x4, y4) = log(arg1)*arg2.
      x4 = x3*x2 - y3*y2
      y4 = x3*y2 + y3*x2

c     Set cxp2_ = exp(log(arg1)*arg2).
      f = exp(x4)
      cxp2_ = cmplx(f*dcos(y4), f*dsin(y4))
      end
      double precision function dabs_(arg)
      double precision arg
      dabs_ = dabs(arg)
      end
      double precision function dacos_(arg)
      double precision arg
      dacos_ = dacos(arg)
      end
      double precision function dasin_(arg)
      double precision arg
      dasin_ = dasin(arg)
      end
      double precision function datan2_(arg1, arg2)
      double precision arg1, arg2
      datan2_ = datan2(arg1, arg2)
      end
      double precision function datan_(arg)
      double precision arg
      datan_ = datan(arg)
      end
      double precision function dcos_(arg)
      double precision arg
      dcos_ = dcos(arg)
      end
      double precision function dcosh_(arg)
      double precision arg
      double precision f, max_double, x
      data max_double/o376777777777777777777777/
      external signal (descriptors)
      x = dabs(arg)
      if (x .gt. 352.8119149050121623d0) then
         call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153")
         dcosh_ = max_double
      else if (x .gt. 22.18) then
         f = dexp(0.5*x)
         dcosh_ = 0.5*f*f
      else
         f = dexp(x)
         dcosh_ = 0.5*(f + 1/f)
      endif
      end
      double precision function ddim_(arg1, arg2)
      double precision arg1, arg2
      ddim_ = ddim(arg1, arg2)
      end
      double precision function dexp_(arg)
      double precision arg
      dexp_ = exp(arg)
      end
      real function dim_(arg1, arg2)
      real arg1, arg2
      dim_ = dim(arg1, arg2)
      end
      double precision function dint_(arg)
      double precision arg
      dint_ = dint(arg)
      end
      double precision function dlog10_(arg)
      double precision arg
      dlog10_ = dlog10(arg)
      end
      double precision function dlog_(arg)
      double precision arg
      dlog_ = dlog(arg)
      end
      double precision function dmod_(arg1, arg2)
      double precision arg1, arg2
      dmod_ = dmod(arg1, arg2)
      end
      double precision function dnint_(arg)
      double precision arg
      dnint_ = dnint(arg)
      end
      double precision function dprod_(arg1, arg2)
      real arg1, arg2
      dprod_ = dprod(arg1, arg2)
      end
      double precision function dsign_(arg1, arg2)
      double precision arg1, arg2
      dsign_ = dsign(arg1, arg2)
      end
      double precision function dsin_(arg)
      double precision arg
      dsin_ = dsin(arg)
      end
      double precision function dsinh_(arg)
      double precision arg
      double precision f, max_double, x, xx
      data max_double/o376777777777777777777777/
      external signal (descriptors)
      x = dabs(arg)
      if (x .gt. 352.8119149050121623d0) then
         call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153")
         dsinh_ = max_double
      else if (x .gt. 22.18) then
         f = dexp(0.5*x)
         dsinh_ = 0.5*f*f
      else if (x .gt. 0.332) then
         f = dexp(x)
         dsinh_ = 0.5*(f - 1/f)
      else if (x .gt. 8.06e-10) then
         xx = x*x
         dsinh_ = x*(1 + xx*(1.666666666666666667d-1
     &                 + xx*(8.333333333333333333d-3
     &                 + xx*(1.984126984126984127d-4
     &                 + xx*(2.755731922398589065d-6
     &                 + xx*(2.505210838544171878d-8
     &                 + xx*(1.60590438368216146d-10)))))))
      else
         dsinh_ = x
      endif
      if (arg .lt. 0) dsinh_ = -dsinh_
      end
      double precision function dsqrt_(arg)
      double precision arg
      dsqrt_ = dsqrt(arg)
      end
      double precision function dtan_(arg)
      double precision arg
      dtan_ = dtan(arg)
      end
      double precision function dtanh_(arg)
      double precision arg
      double precision dcosh_, dsinh_
      if (abs(arg) .gt. 22.18) then
         dtanh_ = dsign(1d0, arg)
      else
         dtanh_ = dsinh_(arg)/dcosh_(arg)
      endif
      end
      real function exp_(arg)
      real arg
      exp_ = exp(arg)
      end
      integer function idnint_(arg)
      double precision arg
      idnint_ = idnint(arg)
      end
      real function alog10_(arg)
      real arg
      alog10_ = log10(arg)
      end
      real function alog_(arg)
      real arg
      alog_ = log(arg)
      end
      integer function nint_(arg)
      real arg
      nint_ = nint(arg)
      end
      real function sign_(arg1, arg2)
      real arg1, arg2
      sign_ = sign(arg1, arg2)
      end
      real function sin_(arg)
      real arg
      sin_ = sin(arg)
      end
      real function sinh_(arg)
      real arg
      real f, max_real, x
      double precision xx
      data max_real/o376777777777/
      external signal (descriptors)
      x = abs(arg)
      if (x .gt. 352.8119) then
         call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153")
         sinh_ = max_real
      else if (x .gt. 9.704) then
         f = exp(0.5*x)
         sinh_ = 0.5*f*f
      else if (x .gt. 0.419) then
         f = exp(x)
         sinh_ = 0.5*(f - 1/f)
      else if (x .gt. 2.11e-4) then
         xx = dprod(x, x)
         sinh_ = x*(1 + xx*(1.666666666666666667d-1
     &                + xx*(8.333333333333333333d-3
     &                + xx*(1.984126984126984127d-4))))
      else
         sinh_ = x
      endif
      if (arg .lt. 0) sinh_ = -sinh_
      end
      real function sqrt_(arg)
      real arg
      sqrt_ = sqrt(arg)
      end
      real function tan_(arg)
      real arg
      tan_ = tan(arg)
      end
      real function tanh_(arg)
      real arg
      if (abs(arg) .gt. 9.704) then
         tanh_ = sign(1e0, arg)
      else
         tanh_ = sinh_(arg)/cosh_(arg)
      endif
      end




		    fort_int_builtins_.fortran      12/27/84  0853.8r w 12/27/84  0838.6       11475



c ******************************************
c *                                        *
c * Copyright, (C) Honeywell Limited, 1984 *
c *                                        *
c ******************************************

      %global ansi77
      integer function iabs_(arg)
      integer arg
      iabs_ = iabs(arg)
      end
      integer function idim_(arg1, arg2)
      integer arg1, arg2
      idim_ = idim(arg1, arg2)
      end
      integer function index_(arg1, arg2)
      character*(*) arg1, arg2
      index_ = index(arg1, arg2)
      end
      integer function isign_(arg1, arg2)
      integer arg1, arg2
      isign_ = isign(arg1, arg2)
      end
      integer function len_(arg)
      character*(*) arg
      len_ = len(arg)
      end
      integer function mod_(arg1, arg2)
      integer arg1, arg2
      mod_ = mod(arg1, arg2)
      end
      integer function ilr_(arg1, arg2)
      integer arg1, arg2
      ilr_ = ilr(arg1, arg2)
      end
      integer function ils_(arg1, arg2)
      integer arg1, arg2
      ils_ = ils(arg1, arg2)
      end
      integer function irl_(arg1, arg2)
      integer arg1, arg2
      irl_ = irl(arg1, arg2)
      end
      integer function irs_(arg1, arg2)
      integer arg1, arg2
      irs_ = irs(arg1, arg2)
      end




		    fortran_buffer_.cds             12/27/84  0853.8rew 12/27/84  0838.6       25092



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

/* format: style3,^delnl,linecom */
fortran_buffer_:
     proc;


/* This cds program initializes and creates the FORTRAN buffer segment	*/
/* used as the file state blocks for fortran io files. R.Schoeman 11/76	*/
/* Modified:
		6 June 1977, D. Levin for new I/O system.
*/

dcl	sys_info$max_seg_size
			external fixed bin (18);
dcl	1 my_buffer	like fortran_buffer_;

dcl	1 my_cds_args	like cds_args;

dcl	create_data_segment_
			entry (ptr, fixed bin (35));
dcl	com_err_		entry options (variable);

dcl	(addr, binary, length, null, rel, size, unspec)
			builtin;

dcl	p		ptr;
dcl	exclude_array	(1) char (32) init ("**");
dcl	code		fixed bin (35) init (0);

%include fortran_buffer;
%include fortran_io_consts;
%include cds_args;


	unspec (my_cds_args) = "0"b;

	unspec (my_buffer) = "0"b;

	my_buffer.table.switch_p = null;		/* aggregate assignment */

	my_buffer.table (5).default_input = "1"b;
	my_buffer.table (41).default_input = "1"b;

	my_buffer.table (6).default_output = "1"b;
	my_buffer.table (42).default_output = "1"b;

	my_buffer.table (6).printer_file = "1"b;
	my_buffer.table (42).printer_file = "1"b;

	my_buffer.maximum_buffer = (sys_info$max_seg_size - (size (fortran_buffer_) - 1));
						/* The * 4 is because its 4 chars per word */

	my_buffer.all_files_closed = "1"b;

	my_buffer.table (0).connected = "1"b;
	my_buffer.table (0).formatted_records = "1"b;
	my_buffer.table (0).direction.in = "1"b;
	my_buffer.table (0).direction.out = "1"b;
	my_buffer.table (0).allow.seq_access = "1"b;
	my_buffer.table (0).carriage_controllable = "1"b;

	my_buffer.table (0).type_of_io = stream_file;
	my_buffer.table (0).open_code = 3;		/* stream_input_output */
	my_buffer.table (0).previous = open_opr;
	my_buffer.table (0).switch_ready = "1"b;




	my_cds_args.have_text = "1"b;
	my_cds_args.seg_name = "fortran_buffer_";
	my_cds_args.struct_name = "my_buffer";
	my_cds_args.sections (1).len = size (fortran_buffer_) - 1;
						/* the -1 is cause last word doesn't really exist but is a kludge */
	my_cds_args.sections (1).p = addr (my_buffer);

	my_cds_args.num_exclude_names = 1;
	my_cds_args.exclude_array_ptr = addr (exclude_array);

	call create_data_segment_ (addr (my_cds_args), code);

	if code ^= 0
	then call com_err_ ("Call to create_data_segment_ to create fortran_buffer_ failed.");

     end;




		    fortran_io_.pl1                 08/06/87  1148.6rew 08/06/87  1045.1     2434104



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



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bugs 427, 451, 453, 454, 464, and 467.
  2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bugs 122 and 490 (SCP6284).
  3) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen),
     install(87-08-06,MR12.1-1069):
     Implemented SCP 6315: Fortran runtime error handler argument.
                                                   END HISTORY COMMENTS */


/* format: style2 */
fortran_io_:
     procedure options (support);			/* This entry must not be referenced */

	call print_error (fortran_io_error_$fio_sys_error, me, "Wrong fortran_io_$fortran_io_ entry.");



/* Written:	6 August 1973, David Levin
*/
/* Modified:
          15 May 87, RW SCP 6315: added the -debug_io argument to call 
                    cu_$cl after an I/O error.
	22 Jan 86, SH & AG - 490: Add "append" option to the "status"
		keyword in the "open"statement.
          25 Nov 85, RW - 122: Changed max number of items in a format
                    statement to 1023, up from 510
	12 Sept 85, BW - 467: Return an error message when attempting
		to write beyond the end of files attached with -no_end.
	09 Sept 85, BW - 427: Remove "kludge_for_no_end" procedure
		since vfile_ now supports "-no_end" for unstructured
		files.  This also fixes the incorrect opening
		of a non-existant random binary stream file.
	09 Aug 85, BW - 464: Check that user specified filenames, I/O
		switch names, and attach descriptions aren't blank.
	23 May 85, BW - 454: Allow a character string to overwrite itself
	          when used as an internal file.
	16 May 85, BW - 453: Make list termination characters ";" and "/" 
	          work properly.
	07 May 85, BW - 451: Return a "noentry" status code when opening non-existent files with status="old".
	22 Jan 85, MM - 448: Make sure that the variable "current" is always
		initialized by fortran_io_$read_or_write.
	27 Aug 84, BW - 440: Fix F-formatting error of numbers between -.5 and 0.
	09 May 84, MM - 404: Make "version" entry use fort_version_info
	28 Mar 84, MM - Install HFP support.
	25 Aug 83, MM - 402: Pad output records to tape_nstd_ to make them
	          word aligned.
	19 Aug 83, MM - 400: Fix suppression of newlines in an absout.
	14 July 83, MM - 407: Create new entry point: "set_cc_defer" for set_cc
		command.
	14 July 83, MM - 406: Allow fortran_io_ to delete files it didn't create.
	14 July 83, MM - 116: Fix defaulting to formatted files.
	20 June 83, TO - 405: Speedup getting data type by index conversion table.
	04 May 83, MM - 98: Correct error code for 2 open statement errors.
	04 May 83, MM - 93: Change the nonstandard fortran character "|"
	          to "I" in one of the error messages. 
	04 May 83, TO - 372: Fix namelist_io to pick up the runtime_block
		from the namelist symbol's father (skip back as necessary
		to find a level 0).
	18 Mar 83, HH - Install LA/VLA support.
	18 Mar 83, RG - 123: Make 'close_for_stop' realize that a unit can be
		connected but not attached nor opened by 'fortran_io_'.
	10 Mar 83, HH - 101: Prevent F-format output in '77 mode from
		displaying minus zero.
	08 Mar 83, HH - 83/91/95/97: Remove incorrect MR9 fix for bug 83
		(TR 6459) in blocked files (i.e. change the value of
		'open_modes (4).for_output' back to 6) and supply the
		correct fix:  Never use 'sqio' mode for blocked files.
	24 Feb 83, HH - 120: Fix list-directed output in '77 mode to supply
		a leading space for carriage control if the 'carriage'
		attribute is off.
	09 Feb 83, HH - 119: Hang changes to format of list-directed and
		namelist output off the 'ansi_77' switch, so old programs
		don't break.
	24 Nov 82, HH - 118: Change method of doing I format output
		conversion because old way failed for Iw.m format when
		m > 15.  (New way is also a little faster.)
	23 Nov 82, HH - 116: If FORM is not specified in an OPEN statement
		in '77 mode, assume 'FORMATTED' unless ACCESS is specified
		to be 'DIRECT'.
	21 Nov 82, HH - 113: Improve list-directed output by suppressing
		the separator between consecutive items if either is a
		character value.
	21 Nov 82, HH - 112: Improve list-directed output of numbers in F
		format by requiring at least 1 digit in the fraction part
		and rounding to suppress trailing 9's in the fraction part.
	04 Nov 82, HH - 111: If scale factor is outside legal range for D
		and E output formats, fill the output field with stars
		rather than terminating the run.
	01 Nov 82, HH - 110: In D, E, F and G input, ignore spaces and zeroes
		before the first significant digit of the mantissa and
		after the last nonzero digit of the fraction part.
	01 Nov 82, HH - 107: If blanks are null, ignore them in D, E, F, G
		and I input while building the decimal representation of
		the input value, rather than by altering the input field.
	30 Oct 82, HH - 109: Make list-directed output of double precision
		values the same as for real values, except allow up to
		18 significant digits.
	29 Oct 82, HH - 108: Remove the restriction that double precision
		constants may not be read into integer or real variables
		with list-directed input.
	29 Oct 82, HH - 100: Fix T, TL, TR and X processing in '77 mode
		so that they alter the position in the record without
		changing its length or transmitting any characters.
	27 Oct 82, HH - 103: Fix logical list-directed input to follow the
		FORTRAN/77 Standard.
	20 Oct 82, TO - 106: Fix internal file write of 'FORMAT ()' to clear
		first record.
	19 Oct 82, TO - 99: Fix inability of list directed character string
		to span records.
	19 Oct 82, TO - 102: Fix formatted output to use an E-type exponent
		for an 'E' or 'G' format specification, and a D-type
		exponent for a 'D' format specification, instead of
		choosing the exponent type according to the data type.
	18 Oct 82, TO - 104: Fix bug in 'get_associated_unit', where iocb_ptr
		not set.
	18 Oct 82, TO - 105: Fix bug in 'INQUIRE' where filename not 'ltrim'd.
	20 Jul 82, HH - Fix I/O bug 96: A file may randomly be opened for INOUT when either IN or OUT is requested in an
		OPEN statement.
	19 Jul 82, HH - Fix I/O bug 94: DECODE randomly gets 'End of info encountered' because it checks 'internal_file_count',
		which is only set for internal file reads.
	17 Jun 82, HH - Hang simulation of EOF records on the 'ansi_77' switch, so old programs don't break.
	19 May 82, HH - Improve NAMELIST and list-directed output:  drop extraneous leading spaces and
		trailing zeroes, and use G-format rather than E-format for real values.
	13 May 82, HH - Make ENDFILE try to reopen for output if unit is open for input only.
	10 May 82, HH - Add 'version' entrypoint to print the version of the compiler at the
		last time 'fortran_io_' was modified.
	10 May 82, HH - Add 'skip_line_numbers' variable so that the list-directed I/O routines
		need not access 'runtime_format'.  This is necessary since a runtime format
		is decoded into a working area used by the list-directed I/O routines!
	07 May 82, TO - Change 'r' format pre-clear to use substr of spaces,
		rather than fio_ps.element_p -> words (1) = 0.
	29 Apr 82, HH - Treat 'error_table_$asynch_deletion' as 'error_table_$no_record' in 'get_record'.
	26 Apr 82, HH - Test for invalid scale factors according to the Standard (cf 13.5.9.2.1).
	21 Apr 82, HH - Quote character values in NAMELIST output so they can be read by NAMELIST input.
	19 Apr 82, HH - Revise implementation of ENDFILE to conform to the Standard.
	25 Mar 82, TO - fix navy test bug 8 - logical input. (2 spots)
	17 Mar 82, TO (for MEP) - fix navy test bug 9 - endfile on non-connected file.
	13 Nov 81, MEP - fix bug 90, ENDFILE ignored.
	6 Nov 81, MEP - finish? INQUIRE, fix bug in t_format (read), and alter stop entry not to use automatic variables
		it does not initialize (e.g. in based_work_area)
	27 Oct 81, MEP - Start of inclusion of INQUIRE statement.
	16 Oct 81, CRD - Change open_mode(4).for_output from 6 to 7 so that
		direct access blocked files get opened in sequential_update
		mode if reopened for output.
	11 Oct 81, Fix open not to break in ansi66 mode for violation of ansi77 rules 	
		and change to fortran_open_data.incl.pl1 (alm).
	3 Oct 81, MEP - Support for ansi77 internal files.  Use of fio_ps.modes = internal_file (like string_io).
	Aug 81, MEP - ansi77 I/O features.
	4 August 1981, CRD - Fix bug 088.
	11 June 1981, CRD - Implement repetition counts in list directed
		input.  Also changed store_null not to store anything if
		in ansi77 mode.
	10 June 1981, CRD - Fix bug 87.
	8 June 1981, CRD - Fix an unreported bug in which buffer_read may
		fault while doing list directed input.
	15 Oct 1980, CRD - Fix bug 82. get_record was being called for a
		direct access binary stream read as well as for each
		element transfer.
	14 Oct 1980, CRD - Fix quote doubling bug in list directed input,
		and use sequential_update rather than
		sequential_input_output for blocked files to avoid 
		truncating the file on each write.
	28 Aug 1980, CRD - Fix many bugs.
	15 Aug 1980, MEP - Add code to calculate the namelist part of fortran77
		character mode stuff.
	12 May 1980, MEP - Add code to implement ansi_77 character array io.
		This causes rewriting of references to char_len, word_len, and
		the calculation of element_count.  This also alters the way in
		which the element_pointer is updated, i.e. by characters
		rather than words.
	04 Aug 1979, PES - Complete the fix to bug 079, by fixing the case
		in which the v format requires additional records, whose
		sequence numbers must also be ignored.  This case was
		inadvertently overlooked in the 22 Jul 79 fix.
	22 Jul 1979, PES - Fix bug 079, in which the s format item is
		ignored in the context "format (s,v)".
	13 Jul 1979, CRD - Implement suggested improvement 078 to make
		namelist input insensitive to case when the program
		unit is compiled with -fold or -card.
	05 Jul 1979, PES - Implement planned feature 074 for "v" format
		output, which was overlooked in the 13 Jun change.
	15 Jun 1979, RAB - fix bug 76 in which an attempt to do a direct
		access write to an empty blocked file causes a "record not
		found".  Bug was introduced by incomplete fix to bug 67.
	13 Jun 1979, PES - fix bug 072 in which fortran_io_ improperly strips trailing blanks
		when doing formatted output to non-terminal files, causing problems with word
		oriented i/o modules; implements planned feature 036, in which the "Close files?"
		query should be eliminated, and planned feature 074, in which upper case 
		characters D, E, F, and T should be used for outputting dp, real, and logical
		values, for compatibility with other systems; and implements suggested
		improvement 007, in which fortran_io_ should print a|7 instead of a$a (a|7)
		in error messages when all the names are the same.
	25 May 1979, PES & RAB - fix bug 75 in which an uninitialized variable in fortran_io_
		(fortran_open_data.char_str) may cause processing of the open statement to
		take an out_of_bounds_fault, with a probability which is initially small
		but which increases with each successive open in a process.
	19 Apr 1979, RAB - fix bug 73 in which an attempt to open a non-vfile_ ( such
		as a tape file) for output causes the file to be initially
		opened for input, causing errors when doing label checking on
		an uninitialized volume.
	19 Dec 1978, PES - fix bug 67 in which an attempt to read a non_existent record
		in a blocked file results in the next-higher record which is present being
		read, with no error indication.  This fix (and other parts of the code)
		assume that direct_access files are being handled by vfile_.  Should this
		cease to be the case, all calls to iox_$control will have to be checked.
	13 Sep 78, PES - fix bug 065, in which fio takes a fault_tag_1 if an attempt is
		made to open a non-existent file; and bug 066, in which an attempt to
		access beyond the end of a direct_access file should result in the err=
		branch being taken, if specified.
	11 Sep 78, PES - Fix bug 064, in which fio will not accept complex input  of the
		form a=(1.,2.) unless a space is added before the ")".
	07 Aug 78, PES - Change signal command_abort_ to call stop_run to interface
		with run unit facility.
	15 Jun 78, DSL - Remove display_fortranio_error (dfe); fix bug in which FORTRAN I/O
		erroneously treats all files as closed even though the user answered "no" to our
		query; leave I/O switch attached if connection fails (this includes changing the
		file closing routines, close_fortran_file, etc., to recognize and properly handle
		this case).
	08 Jun 78, DSL - Fix bug in f-format output in which incorrect format is used if zerodivide
		is signalled during conversion; fix bug in which /-format is ignored if it is the
		first field desc.
	05 Jun 78, DSL - Implement display_fortranio_error (dfe); create structure for all double
		word variables; move all "static" declarations to ext proc; change "syntax_error",
		"too_much_input", "too_much_output", "conversion_error", "bad_char", to entry points.
		Fix bug in format processing in which an excess right parenthesis causes faults.
		Recognize "IOS compatability" as a valid open description.
	11 May 78, DSL - Fix open to attempt input only opening if incorrect access to write and
		user did not explicitly request write access; minor change to get_open_field.
	25 Apr 78, DSL - Minor change to allow fio to recover if old fio is invoked before new fio.
	05 Apr 78, DSL - Only print input record if it is relevant to the error message; insure
		that rel(frd_$fio_buf_p) >= area_size; use ioa_$ioa_switch to print warnings instead
		of com_err_ (bug 54); support iostat var for EOF; do not trim white space if
		$-format is used; use -extend if fio creates attach desc for vfile_ and file is open for
		output (this also means that the file is rewound after it is opened); file is
		opened for output if: inout and fio attach desc or empty file; recognize if any
		type of vfile_ file is empty; on error, print input record using ioa_$ioa_switch
		rather than com_err_; also, print pointer to bad char; allow "$" and "_" in
		variable names for namelist input (bug 55).
	21 Mar 78, DSL - Convert to new format representation; completely rewrite
		carriage control code.
	06 Feb 78, DSL - Fix char control code to only print one blank line for the
		format "(1h )". Also fix deferred output to put newlines between its records.
	03 Jan 78, DSL - More changes for "static" stack frames.
	19 Dec 77, DSL - Changed to support new "static" stack frame. Stack frame
		for fortran_io_ is pushed the first time any entry point is referenced by a
		given user stack frame and is popped with the user stack frame.
	06 Dec 77, DSL - Bug fixes:  Finish handler should be an external entry not an
		internal entry; proc get_record does not set record_found correctly (introduced
		on 23 Nov 77). Also, more clean up in formatted I/O.
	23 Nov 77, DSL - Bug fixes: correct handling of empty (or nonexistent) files;
		suppress newline char for structured files; put "-no_end" in attach desc for
		blocked files.
	15 Nov 77, DSL - Fix open statement to recognize unstructured file as possible
		binary stream file. Also clean up changes started 10/24/77.
	24 Oct 77, DSL - some quickie speedups. a) copy format as it is used to minimize
		number of times it is unpacked. b) change write_a_record to call iox_$put_chars
		only at the end of the write statement rather than at each newline character.
	19 Sep 77, DSL - allow backspace even if file is at BOF; fix list-dir output to
		print imaginary part of complex value.
	07 Sep 77, DSL - implement status specifier for close statement.
		fix bug in open for nonexistent blocked file.
	30 Aug 77, DSL - delete extra comma in namelist output; prevent printing
		of record on EOF error; file 0 is not closed; change defer_newline to affect
		generation of all carriage_controllable files.
		NOTE -- implementation of defer attr conflicts with documentation with this change.
	11 Aug 77, DSL - Bug fixes: close_file does not close 0 if nothing else is open;
		wrong open modes for tape_mult_; EOF on binary files not detected correctly;
		iostat var must always be set if given; form only allowed when connecting; fix error
		messages; implement rewind for tape I/O modules.
	02 Aug 77, DSL - Change reopen; implement s-format; better treatment of terminal files.
	21 Jul 77, DSL - fix bugs; change inplementation for opening a nonexistent file
		for inout; prevent close files query for fast or dfast;
		April thru June 1977 David Levin - Completely restructured. Obsolete code removed. */

/*	This program extensively changed 11/76 to fix many bugs, improve	*/
/*	performance, and change actions performed. --R.Schoeman		*/


/* 	The following comments outline the implementatin of "static" stack frame. Refer to MCR 3153.


               When a FORTRAN program's stack frame is created and the program performs I/O,
          stack_frame.ps_ptr is initialized as an ITS pair pointing to the PS for the program.  This
          field is never modified again by the object segment or by pl1_operators_.  In this change
          to the implementation of fortran_io_, I propose using the high-order bit of this field as
          flag.  The bit is ignored if the field is used as an ITS pair and the value of this bit is
          zero when the ITS pair is stored.

               All FORTRAN programs reference fortran_io_, the support procedure for FORTRAN I/O,
          via operator calls (to pl1_operators_, of course).  Therefore, all valid references to
          fortran_io_ support entry points enter fortran_io_ via pl1_operators_. Once in
          pl1_operators_, the sign of stack_frame.ps_ptr indicates the value of our flag.


                                        First Reference to fortran_io_

               The first time fortran_io_ is referenced from a (user) stack frame, the sign of
          stack_frame.ps_ptr is positive because the high-order bit is zero.  In this case, a full
          PL/I call is made to the appropriate support entry point in fortran_io_.  (It does not
          matter which entry point is used to create the stack frame for fortran_io_.)  Once within
          fortran_io_ the following actions are performed in order to implement the "static" stack
          frame for fortran_io_:

            1. Copy fortran_io_'s stack_frame|4 to the user's stack_frame|4. This field is used by
               PL/I and FORTRAN to determine the true end of the stack frame when a temporary stack
               extension is freed.  By copying this field, a temporary stack extension in the user's
               stack frame will not cause an accidental freeing of fortran_io_'s stack frame.

            2. Store the address of a PL/I goto statement within fortran_io_ at fio_ps.label_addr.
               This goto statement contains a subscripted reference to a label array, in which the
               variable mentioned below in item 3 is the subscript, to transfer control to the
               correct support entry point in fortran_io_.  (N.B. - The structure "fio_ps" is in
               fortran_io_'s stack frame.)

            3. Store the address of a fortran_io_ variable at fio_ps.label_index_addr.  This
               variable is used as the subscript of the label array reference mentioned above.  Code
               in pl1_operators_ uses this address to store the value of index register 6.  The
               value of this register identifies the support entry point desired.  The variable
               itself is initialized to zero.

            4. Store the address of fortran_io_'s stack frame at fio_ps.stack_frame_p.

            5. Store a packed ptr to fio_ps at the user's stack_frame.support_ptr.

            6. Set high-order bit of the user's stack_frame.ps_ptr to "1"b.

            7. Now that the stack frames are properly set up and control is at the appropriate entry
               point, fortran_io_ can perform the requested task.


                                     Subsequent References to fortran_io_

               If the sign of the user's stack_frame.ps_ptr is negative, the high-order bit of the
          word is "1"b and this indicates that a stack frame already exists for fortran_io_.  In
          this case the following actions are performed instead of a PL/I call:

            1. The value of index register 0 is stored at the user's stack_frame.return_ptr+1.  This
               field now forms an ITS pair pointing the return point in the user's program.

            2. A pointer to fortran_io_'s stack frame, obtained from fio_ps.stack_frame_p, is stored
               in the user's stack_frame.next_sp. (Fortran_io_'s stack_frame.prev_sp does not have
               to be set as it is still valid from when the stack frame was created.)

            3. The sp, pr6, is loaded from fio_ps.stack_frame_p.

            4. The value of index register 6 is stored indirectly through fio_ps.label_index_addr
               using a "sxl6" instruction.  This sets the value of the fortran_io_ variable, i.e.,
               sets the subscript of the label array reference.

               Control is now transferred indirectly through fio_ps.label_addr.  This results in
               tranferring to the PL/I goto statement mentioned earlier and the execution of that
               statement results in a transfer to the appropriate entry point within fortran_io_.

            5. Control is now in fortran_io_ with pr6 pointing to the correct stack frame!!  Perform
               the requested task.


                                          Returning From fortran_io_

               In order to return control to the user program, return_to_user$special_return is
          called. This routine:

           - copies fortran_io_'s stack_frame.next_sp into the user's stack_frame.next_sp (this
             makes fortran_io_'s stack frame part of the user's frame)
           - sets pr6 to the user's frame
           - does a short_return

               Fortran_io_'s stack frame is now part of the user's stack frame and remains so until
          the next I/O operation. Each user stack frame has its own fortran_io_ stack frame.


                                                     Notes

               The procedure fortran_io_ must never execute a return_mac, i.e., a return from the
          external procedure fortran_io_, or fortran_io_'s stack frame goes away while the flag in
          the user's stack frame proclaims its existence.

               The procedure return_to_user.alm was initially added to bound_fortran_io_ in order to
          provide a faster non-local return for the FORTRAN err= and end= exits.  It now performs
          that function, following the guidelines outlined here, as well as the "normal" return
          mentioned above.

               The following include files and source segments are used to implement these changes:

                    fortran_io_.pl1
                    fortran_ps.incl.alm
                    fortran_ps.incl.pl1
                    pl1_operators_.alm
                    return_to_user.alm
                    stack_frame.incl.alm
                    stack_frame.incl.pl1
*/


/*	The following structure is declared to insure that all double word variables
		are close packed. Using a structure prevents storage allocation dependencies. */

	dcl     1 dummy_for_double_word_alignment
				 aligned structure,
		2 PS_ptr		 ptr,
		2 block_pt	 ptr,
		2 buffer_seg_pointer ptr,
		2 buffer_pointer	 ptr,
		2 constant_ptr	 ptr,
		2 count_pt	 ptr,
		2 end_pt		 ptr,
		2 fcb_ptr		 ptr,
		2 fmt_ptr		 ptr,
		2 format_p	 ptr,
		2 iocb_ptr	 ptr,
		2 link_pt		 ptr,
		2 name_pt		 ptr,
		2 namelist_name_ptr	 ptr,
		2 ok_pt		 ptr,
		2 subs_pt		 ptr,
		2 symbol_pt	 ptr,
		2 table_pt	 ptr,
		2 text_pt		 ptr,
		2 user_sp		 ptr;


	dcl     1 file_desc		 like fortran_buffer_.table aligned based (fcb_ptr);

	dcl     CPDW		 fixed bin (8) init (8) int static options (constant);
	dcl     CPW		 fixed bin (8) init (4) int static options (constant);
	dcl     EOF1		 char (1) aligned int static options (constant) init ("");
						/* \034 */
	dcl     EOF2		 char (2) aligned int static options (constant) init ("\f");
						/* \134 \146 */
	dcl     EOF3		 char (2) aligned int static options (constant) init ("\F");
						/* \134 \106 */
	declare FALSE		 bit (1) int static options (constant) init ("0"b);
	declare TRUE		 bit (1) int static options (constant) init ("1"b);

	dcl     fio_data_type_index	 (0:63) static options (constant)
				 initial (0, 6, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2,
				 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
				 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1);

	declare abs		 builtin;
	declare add_char_offset_	 entry (ptr, fixed bin (21)) returns (ptr) reducible;
	dcl     addr		 builtin;
	dcl     addrel		 builtin;
	dcl     area_size		 fixed bin int static options (constant) init (2048);
	dcl     assign_round_	 entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35));
	dcl     attach_desc_len	 fixed bin;
	dcl     b_var_str		 char (256) varying based;
	dcl     base		 fixed bin (3);
	dcl     baseno		 builtin;
	dcl     baseptr		 builtin;
	dcl     begin_index		 fixed bin (21);
	dcl     binary		 builtin;
	dcl     binary_type		 (4) fixed bin init (6, 9, 94, 97) internal static options (constant);
	dcl     binary_prec		 (4) fixed bin (35) init (27, 63, 27, 63) internal static options (constant);
	dcl     bin_type		 fixed bin;
	dcl     bit		 builtin;
	dcl     buffer_index	 fixed bin (21);
	dcl     buffer_length	 fixed bin (21);
	dcl     buffer_max_len	 fixed bin (21);
	dcl     call_sw		 fixed bin (1);	/* <0 first; =0 all others; >0 last */
	dcl     capital_letters	 char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	dcl     ch		 char (1) aligned;
	dcl     char_len		 fixed bin (21);
	declare char_offset		 fixed binary (21);
	dcl     character_type	 fixed bin static options (constant) init (6);
	dcl     chars_left		 fixed bin (21);
	dcl     chars_per_item	 fixed binary (21);
	dcl     chars		 char (4096) based;
	declare code		 fixed binary (35);
	dcl     column_one		 fixed bin;
	dcl     com_err_		 entry options (variable);
	dcl     convert		 builtin;
	dcl     copy		 builtin;
	dcl     count		 fixed bin;
	dcl     create_if_not_found	 bit (1) aligned int static options (constant) init ("1"b);
	dcl     cu_$cl                 entry (bit (1) aligned);
	dcl     cu_$stack_frame_ptr	 entry () returns (ptr);
	dcl     current		 fixed bin (4);
	dcl     dec_flt		 float decimal (59) aligned based (addr (work));
	dcl     dec_int		 fixed decimal (11) aligned based (addr (work));
	dcl     default_error_handler_$add_finish_handler
				 entry (entry, fixed bin (35));
	dcl     delete_$path	 entry (char (*), char (*), bit (6), char (*), fixed bin (35));
	dcl     dexp		 fixed decimal (3);
	declare dirname		 character (168);
	dcl     divide		 builtin;
	dcl     dp_flt_pic		 picture "-9.v(17)9es99" aligned based (addr (work));
	dcl     dp_fxd_pic		 picture "(18)-9.v(21)9" aligned based (addr (work));
	dcl     data_type_of_prev_item fixed bin;
	dcl     e			 fixed bin;
	dcl     element_count	 fixed bin (24);
	dcl     entry_point		 fixed bin;
	declare entryname		 character (32);
	dcl     error_table_$asynch_deletion
				 fixed bin (35) ext static;
	dcl     error_table_$end_of_info
				 fixed bin (35) ext static;
	dcl     error_table_$moderr	 fixed bin (35) ext static;
	dcl     error_table_$no_file	 fixed bin (35) ext static;
	dcl     error_table_$no_operation
				 fixed bin (35) ext static;
	dcl     error_table_$no_record fixed bin (35) ext static;
	dcl     error_table_$noentry	 fixed bin (35) ext static;
	dcl     error_table_$pathlong	 fixed bin (35) ext static;
	dcl     error_table_$short_record
				 fixed bin (35) ext static;
	dcl     exists		 bit (1) aligned;
	dcl     exists_file_code	 fixed bin;
	dcl     expand_pathname_	 entry (char (*), char (*), char (*), fixed bin (35));
	dcl     exps		 char (4) aligned int static options (constant) init ("edED");
	dcl     ext_float_decimal	 fixed bin internal static options (constant) init (162);
	dcl     fast_related_data_$fortran_buffer_p
				 ptr ext static;
	dcl     fast_related_data_$fortran_io_initiated
				 bit (1) aligned ext static;
	dcl     fast_related_data_$in_dfast
				 bit (1) aligned ext static;
	dcl     fast_related_data_$in_fast_or_dfast
				 bit (1) aligned ext static;
	dcl     fast_related_data_$terminate_run
				 ext static entry variable;
	dcl     fixed		 builtin;
	dcl     fixedoverflow	 condition;
	dcl     flt_pic		 picture "-9.v(7)9es99" aligned based (addr (work));
	dcl     format_type		 (0:3) char (13) int static options (constant)
				 init ("List-directed", "Unformatted", "Formatted", "Namelist");
	dcl     fortran_buffer_$	 ext static;
	dcl     fortran_io_error_$access_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$already_connected
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$already_opened
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$attach_desc_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$bad_char
				 fixed bin (35) ext static;
	declare fortran_io_error_$blank_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$cannot_position
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$cannot_read
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$cannot_reopen
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$cannot_truncate
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$cannot_write
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$conversion_error
				 fixed bin (35) ext static;
	declare fortran_io_error_$close_attr_error
				 fixed binary (35) external static;
	dcl     fortran_io_error_$dnumeric_file
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$filename_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$fio_sys_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$form_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$format_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$format_is_infinite
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$formatted_file
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$incompatible_opening
				 fixed bin (35) ext static;
	declare fortran_io_error_$internal_file_oflow
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$invalid_file0_attr
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$invalid_file0_type
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$invalid_for_file0
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$io_switch_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$long_record
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$missing_header
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$mode_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$must_be_empty
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$namelist_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$not_blocked
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$not_direct
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$not_open
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$not_scratch_file
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$not_sequential
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$open_attr_conflict
				 fixed bin (35) ext static;
	declare fortran_io_error_$open_attr_incomplete
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$parens_too_deep
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$read_after_eof
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$short_record
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$status_field_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$syntax_error
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$unformatted_file
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$unknown_filetype
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$write_after_eof
				 fixed bin (35) ext static;
	dcl     fortran_io_error_$wrong_mode
				 fixed bin (35) ext static;
	dcl     fxd_pic		 picture "(8)-9.v(11)9" aligned based (addr (work));
	dcl     general_format_parse_$runtime
				 entry (char (1024) aligned, char (4096) aligned, bit (1) aligned, fixed bin (35))
				 ;
	declare get_pdir_		 entry () returns (char (168));
	dcl     have_runtime_format	 bit (1) aligned;
	dcl     hbound		 builtin;
	declare hcs_$status_long	 entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
	declare hcs_$status_minf	 entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
				 fixed bin (35));
	dcl     i			 fixed bin (18);
	dcl     illegal_return	 condition;
	dcl     in		 fixed bin;
	dcl     index		 builtin;
	dcl     integer_dtype	 fixed bin init (2) internal static options (constant);
	dcl     integer_prec	 fixed bin (35) init (35) internal static options (constant);
	dcl     interactive		 bit (1);
	declare internal_file_count	 fixed binary (17);
	dcl     int_pic		 picture "(15)-9" aligned based (addr (work));
	dcl     io_buf		 char (buffer_length) based (buffer_pointer);
	dcl     ioa_$ioa_switch	 entry options (variable);
	dcl     iox_$attach_iocb	 entry (ptr, char (*), fixed (35));
	dcl     iox_$close		 entry (ptr, fixed bin (35));
	dcl     iox_$control	 entry (ptr, char (*), ptr, fixed bin (35));
	dcl     iox_$detach_iocb	 entry (ptr, fixed bin (35));
	dcl     iox_$error_output	 ptr ext static;
	dcl     iox_$get_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$get_line	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$find_iocb	 entry (char (*) aligned, ptr, fixed bin (35));
	dcl     iox_$open		 entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
	dcl     iox_$position	 entry (ptr, fixed bin, fixed bin (21), fixed bin (35));
	dcl     iox_$put_chars	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$read_record	 entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
	dcl     iox_$rewrite_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$seek_key	 entry (ptr, char (256) var, fixed bin (21), fixed bin (35));
	dcl     iox_$write_record	 entry (ptr, ptr, fixed bin (21), fixed bin (35));
	dcl     iox_$user_input	 ptr ext static;
	dcl     iox_$user_io	 ptr ext static;
	dcl     iox_$user_output	 ptr ext static;
	dcl     j			 fixed bin (18);
	dcl     k			 fixed bin (18);
	dcl     l			 fixed bin (18);
	dcl     last		 fixed bin (21);
	declare lbound		 builtin;
	dcl     length		 builtin;
	dcl     lower_letters	 char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
	dcl     ltrim		 builtin;
	dcl     max_fixed		 fixed bin int static options (constant) init (11);
	dcl     max_float		 fixed bin int static options (constant) init (59);
	dcl     me		 char (12) init ("fortran_io_") int static options (constant);
	dcl     min		 builtin;
	dcl     mod		 builtin;
	declare must_produce_plus	 bit (1) aligned;
	dcl     my_code		 fixed bin (35);
	dcl     new_buffer_length	 fixed bin (21);
	declare no_uid		 bit (36) aligned internal static options (constant) initial (""b);
	dcl     null		 builtin;
	dcl     operation_name	 (0:14) char (12) int static options (constant)
				 init ("ZERO-ERROR", " write", "Old endfile", " read", "Rewind", "Unused 5",
				 "Closefile", "Close", "Backspace", "Inquire", "Openfile", "Open", "Margin",
				 "Unused 13", "Endfile");
	dcl     overflow		 condition;
	dcl     overflow_label	 label;
	dcl     pl1_operators_$VLA_words_per_seg_
				 fixed bin (19) ext;
	dcl     prec		 fixed bin;
	dcl     process_type	 fixed bin;
	dcl     prompt_char		 char (4) aligned int static init ("?   ") options (constant);
	dcl     psp		 ptr;
	dcl     ptr		 builtin;
	dcl     rel		 builtin;
	dcl     return_if_not_found	 bit (1) aligned int static options (constant) init ("0"b);
	dcl     return_to_user	 entry (ptr, ptr);
	dcl     return_to_user$special_return
				 entry;
	dcl     round		 builtin;
	dcl     rtrim		 builtin;
	dcl     search		 builtin;
	dcl     sent		 fixed bin (21);
	dcl     size		 condition;
	dcl     skip_line_numbers	 bit (1);
	dcl     stop_run		 external entry;
	dcl     str_len		 fixed bin;
	dcl     string		 builtin;
	dcl     substr		 builtin;
	dcl     suppress_final_newline bit (1) aligned;
	dcl     sys_info$max_seg_size	 fixed bin (18) ext static;
	dcl     terminal_file	 bit (1) aligned;
	dcl     translate		 builtin;
	dcl     underflow		 condition;
	declare unique_chars_	 entry (bit (*)) returns (char (15));
	dcl     unspec		 builtin;
	dcl     user_info_$process_type
				 entry (fixed bin);
	dcl     verify		 builtin;
	declare vfile_status_	 entry (char (*), char (*), ptr, fixed bin (35));
	dcl     white_space		 char (2) aligned int static options (constant) init (" 	");
						/* SP TAB */
	dcl     word_len		 fixed bin (19);
	dcl     words		 (2) fixed bin (35) aligned based;
	dcl     zero_label		 label;
	dcl     zerodivide		 condition;


/* WARNING !!! these structures proport to know the internal representation of extended float decimal data */

	dcl     1 number		 aligned structure based (addr (work)),
		2 sign		 char (1) unaligned,
		2 digit		 char (prec) unaligned,
		2 exp		 fixed bin (8) unaligned,
	        1 flt_dec		 aligned structure based (addr (work)),
		2 pad1		 char (60) unaligned,
		2 exp		 fixed bin (8) unaligned;

	dcl     1 word_align_1	 aligned based,
		2 based_bits	 bit (72) unaligned;

	dcl     1 word_align_2	 aligned based,
		2 based_dp	 float bin (63) unaligned;

	dcl     1 word_align_3	 aligned based,
		2 double_word	 fixed bin (71) unaligned;


/* I/O module information. */

	dcl     1 open_mode		 (13) aligned structure int static options (constant),
		2 io_type		 bit (3) unal init ((3) (1)"001"b, (10) (1)"010"b),
		2 direction	 unaligned structure,
		  3 in		 bit (1)
				 init ("1"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b,
				 "1"b),
		  3 out		 bit (1)
				 init ("0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "1"b,
				 "1"b),
		2 for_input	 fixed bin (4) unal init (0, 1, 0, 0, 4, 0, 0, 0, 8, 0, 0, 11, 0),
		2 for_output	 fixed bin (4) unal init (3, 0, 2, 6, 0, 7, 5, 10, 0, 9, 13, 0, 12);



/* Structures for formatted input/output processing. These overlay the buffer. */

/* Used to clear first record of internal file write. */

	dcl     buffer		 char (buffer_max_len) based (buffer_pointer);


	dcl     1 record_structure	 aligned structure based (buffer_pointer),
		2 pad		 char (buffer_index) unaligned,
						/* these are already processed */
		2 rest_of_record	 char (buffer_length - buffer_index) unaligned;
						/* What's left of the record */

	dcl     1 field_structure	 aligned structure based (buffer_pointer),
		2 pad		 char (buffer_index) unaligned,
						/* these are already processed */
		2 rest_of_field	 char (last - buffer_index) unaligned;
						/* What's left of the field */

	dcl     1 output_structure	 aligned structure based (buffer_pointer),
		2 pad		 char (buffer_length) unaligned,
						/* these are already processed */
		2 rest_of_output	 char (1024) unaligned;
						/* What's added to the output record */

/* valid values for fields in open and close statements */

	declare open_status_values	 (5) char (12) varying internal static options (constant)
				 init ("unknown", "new", "old", "scratch", "append");

	declare open_mode_values	 (3) char (12) varying internal static options (constant)
				 init ("in", "out", "inout");

	declare open_access_values	 (2) char (12) varying internal static options (constant)
				 init ("sequential", "direct");

	declare open_form_values	 (2) char (12) varying internal static options (constant)
				 init ("formatted", "unformatted");

	declare open_blank_values	 (2) char (12) varying internal static options (constant) init ("null", "zero");

	declare close_status_values	 (2) char (12) varying internal static options (constant) init ("keep", "delete");

/* various named constants */

	declare new_file		 fixed bin int static options (constant) init (1);
	declare old_file		 fixed bin int static options (constant) init (2);
	declare scratch_file	 fixed bin int static options (constant) init (3);
	declare append_file		 fixed bin int static options (constant) init (4);
	declare unknown_file	 fixed bin int static options (constant) init (0);

	declare COMMA		 char (1) int static options (constant) init (",");
	dcl     two_NLs		 char (2) aligned int static options (constant) init ("

");
	dcl     (
	        SP		 init (" "),
	        NL		 init ("
"),
	        CR		 init (""),
	        FF		 init ("")
	        )			 char (1) aligned internal static options (constant);


	dcl     1 stack_f		 aligned based,
		2 pad		 (2) bit (72) aligned,
		2 sp_up_4		 bit (72) aligned,
		2 pad2		 bit (72) aligned,
		2 xr		 (0:7) fixed bin (17) unal;

/* The following data structure overlays the PS data structure. */


	dcl     1 dfast_communications_area
				 aligned based (addr (PS.data_word (1))),
		2 max_recl	 fixed bin,
		2 pad		 fixed bin,
		2 pathname_ptr	 pointer,
		2 filetype_ptr	 pointer;


/* BUFFER SEGMENT STRUCTURE - These fields are stored in the buffer segment. */

	dcl     1 based_work_area	 aligned based (buffer_seg_pointer),
						/* OFFSET (octal)						LENGTH IN WORDS (octal) */
		2 version		 fixed bin,	/* 0001 */
						/* These fields are used for conversions and should not be overlayed. */
						/*    1*/
		2 work		 char (64) aligned, /* 0020 */
						/*   21*/
		2 work_str	 char (4096) aligned,
						/* 1000 */
						/* These fields are only used by open. */
						/* 1021*/
		2 attachment	 char (256) unaligned,
						/* 0100 */
						/* 1121*/
		2 dir		 char (168) unaligned,
						/* 0052 */
						/* 1173*/
		2 ent		 char (32) unaligned,
						/* 0010 */
						/* 1203*/
		2 ioname		 char (32) aligned, /* 0010 */
						/* 1213*/
		2 info		 (20) fixed bin,	/* 0024 */
						/* These fields allow us to save info from most recent error. */
						/* 1237*/
		2 actual_error	 fixed bin (35),	/* 0001 */
						/* 1240*/
		2 ps_at_error	 ptr;		/* 0002 */

/* 1242 - next free offset */
/* 4000 - last free offset */


	dcl     NL_FF		 char (2) aligned int static options (constant) init ("
");
%include fortran_ps;
%include fortran_buffer;
%include fortran_open_data;
%include fortran_inquire_data;
%include stack_frame;
%include rs_info;
%include iocb;
%include format_tables;
%include vfs_info;
%include iox_modes;

/* IMPLEMENTS THE STATIC STACK FRAME TRANSFER VECTOR */

label_for_entry (0):
	goto label_for_entry (entry_point);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* ENTRY TO INITIATE READ OR WRITE */

read_or_write:
     entry (psp);

	PS_ptr = psp;

	call make_static_frame;

/* The following enables all handlers used during fortran I/O. */

	overflow_label = no_handler;
	zero_label = no_handler;
	on fixedoverflow, overflow, underflow, size goto overflow_label;
	on zerodivide goto zero_label;

label_for_entry (12):				/* read_or_write */
						/* Prepare for I/O operation.  If the operation is not a string operation
   then call initialize_fortran_io to validate the request and initialize the buffer.
   For string I/O requests (encode and decode)and ansi77 internal files set up the various buffer pointers to look right. 
   For internal files, calculate the number of records of the internal file.  
   if PS.buffer_length = 0, then it is not an array and there is 1 record
   else PS.buffer_length gives the number of words for the array (ansi66)
   or the number of characters for the array (ansi77).  See the comment in
   set_size_and_count for a more graphic explanation.
*/
	call_sw = -1;				/* first call */
	if fio_ps.mode = string_io | fio_ps.mode = internal_file
	then do;
		buffer_max_len = PS.max_buffer;
		buffer_pointer = PS.buffer_p;
		if fio_ps.ansi_77
		then char_offset = buffer_max_len;
		else char_offset = divide (buffer_max_len + CPW - 1, CPW, 17, 0) * CPW;

		if fio_ps.read
		then buffer_length = buffer_max_len;
		else buffer_length = 0;
		if fio_ps.mode = internal_file
		then do;
			if ^fio_ps.read & ^fio_ps.list/* clear record */
			then buffer = "";

			if PS.buffer_size = 0	/* internal_file isn't an array */
			then internal_file_count = 1;
			else if fio_ps.ansi_77
			then internal_file_count = divide (PS.buffer_size, buffer_max_len, 17, 0);
			else internal_file_count = divide (PS.buffer_size * CPW, char_offset, 17, 0);
		     end /* internal_file */;
	     end /* string_io and internal_file */;

	if fio_ps.read				/* Determine the I/O operation to be performed. */
	then current = read_opr;
	else current = write_opr;

	call initialize_fortran_io;
	have_runtime_format = "0"b;
	suppress_final_newline = "0"b;
	go to initiate_routine (fixed (fio_ps.format, 2));

initiate_routine (0):				/* Free format I/O(list-directed) */
	overflow_label = conversion_error_handler;
	zero_label = no_handler;

	if fio_ps.read & fio_ps.format = list_directed
	then buffer_index = 0;

	fio_ps.format = list_directed;

/* the parse prevents list_directed I/O on internal files */

	if ^fio_ps.read & fio_ps.mode ^= string_io
	then if (file_desc.printer_file & file_desc.carriage_controllable) | fio_ps.ansi_77
	     then do;
		     if buffer_length = buffer_max_len
		     then call too_much_output;
		     substr (rest_of_output, 1, 1) = SP;/* append NL to existing contents */
		     buffer_length = buffer_length + 1;
		end;
	if fio_ps.read
	then call initialize_list_input ();
	else data_type_of_prev_item = character_type;	/*  Suppress separator before 1st item.  */
	go to initiate_common;

initiate_routine (1):				/* Unformatted I/O. */
	buffer_index = 0;				/* number of words read from buffer so far */
	go to initiate_common;

initiate_routine (2):				/* Formatted I/O. */
	call initialize_formatted_io;

initiate_common:
	if ^fio_ps.list
	then goto terminate_no_list;
	call return_to_user$special_return;

initiate_routine (3):				/* Namelist */
	overflow_label = conversion_error_handler;
	zero_label = no_handler;

	call namelist_io;
	goto terminate_no_list;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* ERROR - ATTEMPT TO ENTER fortran_io_ VIA STANDARD CALL. */

element:
terminate:
     entry (psp);

	PS_ptr = psp;
	fio_ps.file_number = PS.file_number;
	string (fio_ps.job_bits) = string (PS.job_bits);
	fio_ps.error_label, fio_ps.iostat_var, fio_ps.have_input = "0"b;
	fortran_buffer_ptr = fast_related_data_$fortran_buffer_p;

	call print_error (fortran_io_error_$fio_sys_error, me, "Wrong version of pl1_operators_.");



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* ELEMENT CALL - TRANSMIT ONE SCALAR OR ONE ARRAY */

label_for_entry (15):
	call_sw = 0;				/* all others */
	go to element_routine (fixed (fio_ps.format, 2));

element_routine (0):
	if ^fio_ps.end_of_input			/* user can signal end of input; rest of list not set */
	then call list_io;

element_list_abort:
	call return_to_user$special_return;

element_routine (1):
	call unformatted_io;
	call return_to_user$special_return;

element_routine (2):
	call formatted_io;

	call return_to_user$special_return;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* TERMINATE CALL - FINISH UP I/O REQUEST */

label_for_entry (14):
terminate_no_list:
	call_sw = 1;				/* last call */
	if ^fio_ps.read
	then call write_a_record;
return_error_code:
	call return_to_user$special_return;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* FILE CONTROL CALL - PERFORM FILE CONTROL */

file_control:
     entry (psp);

	PS_ptr = psp;

	call make_static_frame;

/* The following enables all handlers used during fortran I/O. */

	overflow_label = no_handler;
	zero_label = no_handler;
	on fixedoverflow, overflow, underflow, size goto overflow_label;
	on zerodivide goto zero_label;

label_for_entry (13):
	call_sw = 0;				/* all others */
	current = binary (fio_ps.control_type, 4, 0);	/*   determine the io operation   */
	call initialize_fortran_io;

	call return_to_user$special_return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* GET AREA PTR CALL - RETURN PTR TO WORK AREA */

get_io_area_ptr:
     entry (psp);					/* Returns a pointer to a work area for open and close statements. */

	PS_ptr = psp;

	call make_static_frame;

/* The following enables all handlers used during fortran I/O. */

	overflow_label = no_handler;
	zero_label = no_handler;
	on fixedoverflow, overflow, underflow, size goto overflow_label;
	on zerodivide goto zero_label;

label_for_entry (22):
	call_sw = 0;				/* all others */
	PS.buffer_p = addr (fortran_buffer_.buf);
	fortran_open_data.char_str = "";
	call return_to_user$special_return;

/* ENTRY POINTS TO IMPLEMENT I/O RELATED FEATURES */

stop:
     entry;

/* Implements file system part of FORTRAN stop statement.  As this is called  with fortran_stop_ on the stack,
   we CANNOT rely on any automatic variables in fortran_io_ having thier values saved, as we can in other entries.
*/

	if fast_related_data_$in_fast_or_dfast
	then call close_all_files ("1"b);		/* dont ask, just close them */
	else call close_for_stop;

	return;


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

finish_handler:
     entry;					/* This entry point is the finish handler for FORTRAN I/O. */

	call close_all_files ("0"b);
	call release_buffer_ptr;
	return;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* Entry to implement the close_file command. */

close_file:
     entry (close_unit, close_code);
	dcl     close_unit		 fixed bin,
	        close_code		 fixed bin (35);

	call get_buffer_ptr (return_if_not_found, exists);/* do not force creation of buffer segment */

	if ^exists				/* no buffer segment, therefore nothing is open */
	then do;
		close_code = 0;
		return;
	     end;


	if close_unit < 0
	then do;					/* Request to close all files. */
		call close_all_files ("0"b);
		close_code = 0;
		return;
	     end;

	if close_unit >= 1 & close_unit <= 99
	then do;					/* request to close particular file. */
		fio_ps.file_number = close_unit;
		fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number));
		iocb_ptr = file_desc.switch_p;

		call close_fortran_file;

		close_code = 0;
		return;
	     end;

	else if close_unit = 0
	then do;
		close_code = fortran_io_error_$invalid_for_file0;
		return;
	     end;

	close_code = error_table_$no_file;

	return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* Entry to implement the set_cc command. */

set_cc:
     entry (cc_unit, status_bit, error_code);
	dcl     cc_unit		 fixed bin,
	        status_bit		 bit (1) aligned,
	        error_code		 fixed bin (35);

	call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */

	if cc_unit < 0 | cc_unit > 99
	then error_code = error_table_$no_file;
	else do;
		fortran_buffer_.table (cc_unit).printer_file = status_bit;
		error_code = 0;

	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* New entry to allow the set_cc command to set defer on. */

set_cc_defer:
     entry (file_unit, cc_bit, defer_bit, defer_specified, err_code);
	dcl     file_unit		 fixed bin,
	        cc_bit		 bit (1) aligned,
	        defer_bit		 bit (1) aligned,
	        defer_specified	 bit (1) aligned,
	        err_code		 fixed bin (35);

	call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */

	if file_unit < 0 | file_unit > 99
	then error_code = error_table_$no_file;
	else do;
		fortran_buffer_.table (file_unit).printer_file = cc_bit;
		if defer_specified
		then fortran_buffer_.table (file_unit).defer_newline = defer_bit;
		error_code = 0;

	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
/* Entry to print the version of the compiler at the last modification to 'fortran_io_'. */

version:
     entry;
	dcl     fort_version_info$greeting
				 char (16) aligned ext static;
	dcl     fort_version_info$version_number
				 char (16) aligned ext static;
	dcl     ioa_		 entry options (variable);

	call ioa_ (rtrim (fort_version_info$greeting) || substr (fort_version_info$version_number, 10));
	return;


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

conversion_error_handler:
	buffer_index = begin_index;			/* Point to beginning of constant for error. */
	call print_error (fortran_io_error_$conversion_error);

no_handler:
	call print_error (fortran_io_error_$fio_sys_error, me, "Condition for which there is no handler.");

get_buffer_ptr:
     proc (a_create_sw, seg_exists);

	dcl     a_create_sw		 bit (1) aligned;	/* "1"b create if not found; "0"b do not create if not found */
	dcl     seg_exists		 bit (1) aligned;	/* "1"b buffer seg already exists; "0"b does not exist */

	dcl     create_sw		 bit (1) aligned;
	dcl     get_segment		 bit (1) aligned;
	dcl     get_temp_segments_	 entry (char (*), (*) ptr, fixed bin (35));
	dcl     release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
	dcl     size		 builtin;


	create_sw = a_create_sw;
	seg_exists = fast_related_data_$fortran_io_initiated;

/* If buffer seg is already initiated, just set up the global pointers. */

	if fast_related_data_$fortran_io_initiated
	then do;
		fortran_buffer_ptr = fast_related_data_$fortran_buffer_p;

/* If rel(fortran_buffer_ptr) < area_size we must increase its value in order to
		prevent an invalid value for buffer_seg_pointer. This code is only needed as
		long as old style fortran_io_'s exist in the system. */

		if fixed (rel (fortran_buffer_ptr), 18) < area_size
		then do;
			unspec (addrel (fortran_buffer_ptr, area_size) -> fortran_buffer_) =
			     unspec (fortran_buffer_ptr -> fortran_buffer_);

			fortran_buffer_ptr = addrel (fortran_buffer_ptr, area_size);
			fast_related_data_$fortran_buffer_p = fortran_buffer_ptr;
						/* so we only do it once a process */

			fortran_buffer_.maximum_buffer =
			     (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW;
		     end;

		buffer_seg_pointer = addrel (fortran_buffer_ptr, -area_size);
		return;
	     end;

	else if ^create_sw
	then return;				/* not there yet, return if we shouldn't create it */

/* Segment is not initiated. (Create and) Inititate it. */

	fortran_buffer_ptr = fast_related_data_$fortran_buffer_p;
						/* Get buffer pointer */

/* First see if we must allocate our own segment. */

	if fortran_buffer_ptr ^= null
	then do;
		get_segment = "0"b;			/* Segment, or part thereof, already allocated */

		buffer_seg_pointer = fortran_buffer_ptr;
		fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = addrel (buffer_seg_pointer, area_size);
	     end;

	else do;

		if ^create_sw			/* not there yet, return if we shouldn't create it */
		then do;
			seg_exists = "0"b;
			return;
		     end;

		get_segment = "1"b;			/* Must free it when we are done */

		call get_temp_segments_ (me, ptr_array, (0));
						/* will never be non-zero */

		buffer_seg_pointer = ptr_array (1);

		fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = ptr (buffer_seg_pointer, area_size);

/* also must establish a finish handler. */

		call default_error_handler_$add_finish_handler (finish_handler, my_code);
		if my_code ^= 0
		then call print_error (my_code, me, "Cannot establish finish handler for FORTRAN I/O.");
	     end;

/* Now initialize.  First assignment to buffer segment is to prevent hardware bug from screwing
	   actual assignment. If hardware bug occurs, first assignment will fail. */

	fortran_buffer_ptr -> words (1) = 0;		/* Insures that initialization is not the first */
						/* reference to the segment. */
	unspec (fortran_buffer_) = unspec (addr (fortran_buffer_$) -> fortran_buffer_);

	fortran_buffer_.maximum_buffer =
	     (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW;

	if get_segment
	then fortran_buffer_.allocated_by_fortran = "1"b;

	if fast_related_data_$in_dfast		/* insure file table entry is right for file 0 */
	then do;
		fortran_buffer_.table (0).prompt = "1"b;
		fortran_buffer_.table (0).defer_newline = "0"b;
		fortran_buffer_.table (0).printer_file = "0"b;
	     end;

	fast_related_data_$fortran_io_initiated = "1"b;
	return;


release_buffer_ptr:
     entry ();					/* Releases buffer seg and resets all external fields. */

	if ^fast_related_data_$fortran_io_initiated	/* i.e., never referenced */
	then return;

	ptr_array (1) = fast_related_data_$fortran_buffer_p;
						/* Get buffer pointer. */

	if ptr_array (1) -> fortran_buffer_.allocated_by_fortran
						/* Release seg only if we allocated it. */
	then do;
		ptr_array (1) = ptr (ptr_array (1), 0);
		call release_temp_segments_ (me, ptr_array, my_code);
		fast_related_data_$fortran_buffer_p = null;
						/* Prevent use of invalid seg no. */
	     end;
	else fast_related_data_$fortran_buffer_p = addrel (ptr_array (1), -area_size);

	fast_related_data_$fortran_io_initiated = "0"b;	/* Segment must be initiated before next use. */
     end get_buffer_ptr;



make_static_frame:
     proc;

/* This procedure is responsible for setting up the "static" frame and setting all fields in the
	   user's stack frame and fortran_io_'s stack frame that are constant. */

	sp = cu_$stack_frame_ptr ();			/* Pointer to our stack frame. */
	user_sp = sp -> stack_frame.prev_sp;		/* Pointer to user's stack frame. */

/* Set fields in fio_ps. */

	fio_ps.file_number = PS.file_number;		/* Copy values from user ps to ours. */
	string (fio_ps.job_bits) = string (PS.job_bits);
	fio_ps.element_p = null;

/* Store a pointer to the label array goto used to enter this procedure and at the
		same time store a pointer to our stack frame. */

	entry_point = 0;				/* To initialize and insure correct address in next stmnt. */
						/* By using a variable index, the optimizer treats all members */
						/* of the label array as having been referenced here. */
	fio_ps.label_for_transfer = label_for_entry (entry_point);

	fio_ps.address_of_index = addr (entry_point);	/* So code in pl1_operators_ can find it. */

/* Update user's stack frame. */

	user_sp -> sp_up_4 = sp -> sp_up_4;		/* So user stack extension works around us. */

	user_sp -> stack_frame.support_ptr = addr (fio_ps);
						/* store in stack frame at reserved location. */
	substr (addr (user_sp -> stack_frame_flags.pl1_ps_ptr) -> based_bits, 1, 1) = "1"b;
						/* tell ops we're initialized. */

/* Initialize constant parts of our stack frame. */

	column_one = 0;

/* Set up the buffer segment. */

	call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */

	ps_at_error = null;
	actual_error = 0;

/* set the "interactive" bit  */

	call user_info_$process_type (process_type);
	if process_type = 1
	then interactive = "1"b;
	else interactive = "0"b;

     end make_static_frame;


initialize_fortran_io:
     procedure;


/* the following table controls the operation performed in response to any given FORTRAN I/O
	   statement. It embodies the logic to maintain the file table entry for each file reference number. */

/* format: off */
dcl	control_matrix(0:14, 0:14) fixed bin int static options(constant) /* bounds depend on the domain of io_op */
		initial (

/* Current		P R E V I O U S    O P E R A T I O N */

/*	       Z   w   o   r   r   u   c   c   b   i   o   o   m   u   e */
/*	       E   r   l   e   e   n   l   l   a   n   p   p   a   n   n */
/*	       R   i   d   a   w   u   o   o   c   q   e   e   r   u   d */
/*	       O   t       d   i   s   s   s   k   u   n   n   g   s   f */
/*	           e   e       n   e   e   e   s   i   f       i   e   i */
/*	               n       d   d   f       p   r   i       n   d   l */
/*	               d           _   i       a   e   l           _   e */
/*	               f           5   l       c       e           1     */
/*	                               e       e                   3     */

/* ZERO      */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,

/* write     */  4,  3, 19,  3,  3, 19, 19, 19,  3, 19,  3,  3, 19, 19,  3,

/* old endf  */  6,  6, 19,  6,  6, 19, 19, 19,  6, 19,  6,  6, 19, 19,  6,

/* read      */  2,  5, 19,  1,  1, 19, 19, 19,  1, 19,  1,  1, 19, 19,  1,

/* rewind    */  9,  9, 19,  9,  0, 19, 19, 19,  9, 19,  0,  9, 19, 19,  9,

/* unused_5  */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,

/* closefile */ 10, 10, 19, 10, 10, 19, 19, 19, 10, 19, 10, 10, 19, 19, 10,

/* close     */ 11, 11, 19, 11, 11, 19, 19, 19, 11, 19, 11, 11, 19, 19, 11,

/* backspace */  8,  8, 19,  8,  0, 19, 19, 19,  8, 19,  0,  8, 19, 19,  8,

/* inquire   */ 12, 12, 12, 12, 12, 19, 12, 12, 12, 12, 12, 12, 12, 19, 12,

/* openfile  */ 15, 15, 19, 15, 15, 19, 19, 19, 15, 19, 15, 15, 19, 19, 15,

/* open      */ 16, 16, 19, 16, 16, 19, 19, 19, 16, 19, 16, 16, 19, 19, 16,

/* margin    */ 17, 17, 19, 17, 17, 19, 19, 19, 17, 19, 17, 17, 19, 19, 17,

/* unused_13 */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,

/* endfile   */  7,  7, 19,  7,  7, 19, 19, 19,  7, 19,  7,  7, 19, 19,  7);

/* format: on */

/* If this is not an inquire statement, get the unit reference number. */

	if current ^= inquire_opr			/* we may not know the unit number */
	then do;
		if fio_ps.file_number >= 1 & fio_ps.file_number <= 99
		then do;
			fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number));
			iocb_ptr = file_desc.switch_p;

			if ^file_desc.connected	/* in dfast, the file must be opened before it is used */
			then if fast_related_data_$in_dfast
			     then if current ^= open_opr & current ^= openfile_opr
				then do;
					k = file_desc.open_code;
						/* get the code that tells why the open failed */
					file_desc.open_code = 0;
						/* next time just say it is closed */

					if k = 0
					then call print_error (fortran_io_error_$not_open);
					else call print_error (binary (unspec (file_desc.switch_p), 35), me,
						"Openfile failed.");

				     end;
		     end /* 1 <= file >= 99 */;

		else if fio_ps.file_number = 0	/* terminal I/O, encode/decode or internal-file */
		then do;
			fcb_ptr = addr (fortran_buffer_.table (0));
			file_desc.blank_null = fio_ps.ansi_77;

			if fio_ps.mode = string_io | fio_ps.mode = internal_file
			then return;

			file_desc.previous = open_opr;/* operations are never dependent on previous operation */
			if current = read_opr
			then do;
				iocb_ptr, file_desc.switch_p = iox_$user_input;

/* If user_input and user_output reference the same target, a read effectively
		   outputs a newline character. Remember this fact. */

				if iox_$user_input -> iocb.actual_iocb_ptr
				     = iox_$user_output -> iocb.actual_iocb_ptr
				then fortran_buffer_.terminal_needs_newline = "0"b;
			     end;

			else if current = write_opr
			then iocb_ptr, file_desc.switch_p = iox_$user_output;

			else if current ^= openfile_opr & current ^= open_opr
			then call print_error (fortran_io_error_$invalid_for_file0);
		     end /* file = 0 */;

		else call print_error (error_table_$no_file);
	     end /* not inquire  */;

/* file table entry is ready;perform appropriate actions */

	if fio_ps.iostat_var
	then PS.iostat_p -> words (1) = 0;		/* value if operation is successful */

/* for inquire operation, we may not know yet which file, and previous doesn't matter anyway */

	if current = inquire_opr
	then goto action (12);
	else goto action (control_matrix (current, file_desc.previous));

/* The logic required to execute any user request is presented here.  If the operation is a file positioning
   request, the code below should completely perform the request.  For input and output transfers of data,
   various housekeeping steps are taken, and in the case of a user request for input, the first record is read. */

action (0):					/* Rewind or backspace after rewind. */
						/* Endfile on non-connected file */
	return;					/* The last operation was more final. Forget I ever called. */

action (2):					/* Read, the first time the file is referenced. */
	dcl     unwritten_eofs	 fixed bin (3) unsigned;

	unwritten_eofs = file_desc.unwritten_eofs;
	call implicit_open;				/* Open the file. */
	file_desc.unwritten_eofs = unwritten_eofs;	/*  Implicit opening clears this field.  */

action (1):					/* Read a record from the designated file. */
	buffer_pointer = addr (fortran_buffer_.buf);
	buffer_max_len = fortran_buffer_.maximum_buffer;

	call validate_mode_and_access;

	file_desc.previous = current;

/* If this is the first call for a direct access read on a binary stream file,
   do nothing.  The records will be read by the element transfer calls. */

	if file_desc.type_of_io = binary_file & call_sw < 0 & fio_ps.list
	then return;

/* A goto is used here instead of a call so that referencing read_a_record is not needed.
	   Of course, I could have made read_a_record a separate procedure... */

	goto read_a_record_label;

action (4):					/* Write, the first time the file is referenced. */
	unwritten_eofs = file_desc.unwritten_eofs;
	call implicit_open;				/* Open the file. */
	file_desc.unwritten_eofs = unwritten_eofs;	/*  Implicit opening clears this field.  */

action (3):					/* An output transfer.  Prepare the buffer for output. */
	call validate_mode_and_access;

	buffer_pointer = addr (fortran_buffer_.buf);
	buffer_max_len = fortran_buffer_.maximum_buffer;

/* If this is a deferred newline file without carriage control, output the first newline now.
	   Moving the code here removes it from "write_a_record" which is an inner loop of fortran_io_. */

	if file_desc.newline_needed & ^(file_desc.printer_file & file_desc.carriage_controllable)
	then do;
		column_one, buffer_length = 1;
		substr (io_buf, 1, 1) = NL;
	     end;
	else buffer_length = 0;

	goto store_op_and_return;

action (5):					/* Read after write. */
	call finish_line;				/* Make sure the last line is completely written. */
	if my_code ^= 0
	then call print_error (my_code);
	go to action (1);

action (19):					/* impossible (current, previous) combination */
	call print_error (fortran_io_error_$fio_sys_error, me, "File table entry is wrong.");

action (10):					/* closefile */
	if ^fast_related_data_$in_dfast
	then goto not_supported;

action (6):					/* Close the file. (closefile, old endfile) */
	call close_fortran_file;
	return;

action (11):					/* Close the file. (close) */
	call close_statement;
	return;

action (12):					/* INQUIRE */
	call inquire_statement;
	return;					/* does no action, dont set op */

action (8):					/* BACKSPACE. */
	if file_desc.unwritten_eofs > 0
	then file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1;
	else if file_desc.switch_ready
	then do;
		if file_desc.connected
		then do;
			if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io
			then call print_error (fortran_io_error_$cannot_position);

			call finish_line;
			if my_code ^= 0
			then call print_error (my_code);
		     end;
		call iox_$position (iocb_ptr, 0, -1, my_code);
		if my_code = error_table_$end_of_info
		then my_code = 0;			/*  We were at BOI.  */
		else if my_code ^= 0
		then call iox_$control (iocb_ptr, "backspace_record", null, my_code);
						/*  Try something else.  */
		if my_code ^= 0
		then call print_error (fortran_io_error_$cannot_position);
	     end;

	goto set_BOR_store_op_and_return;

action (9):					/* REWIND */
	file_desc.unwritten_eofs = 0;			/*  Forget about any unwritten EOF records.  */
	if file_desc.switch_ready
	then do;
		if file_desc.connected
		then do;
			if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io
			then call print_error (fortran_io_error_$cannot_position);

			call finish_line;
			if my_code ^= 0
			then call print_error (my_code);
		     end;

		call iox_$position (iocb_ptr, -1, 0, my_code);
		if my_code = error_table_$end_of_info
		then my_code = 0;			/*  File is empty.  */
		else if my_code ^= 0
		then do;				/* probably failed because not 'vfile_' */
			call iox_$control (iocb_ptr, "rewind", null, my_code);
			if my_code ^= 0		/* probably failed because not 'tape_nstd_' */
			then if file_desc.fortran_opened
			     then do;
				     call iox_$close (iocb_ptr, my_code);
				     if my_code ^= 0
				     then call print_error (fortran_io_error_$cannot_position);

				     file_desc.switch_ready = FALSE;
				     file_desc.newline_needed = "0"b;
				     file_desc.previous = 0;
						/* forces reopen on next data transfer */
				     return;	/* must not execute usual exit code */
				end;
		     end;

		if my_code ^= 0
		then call print_error (fortran_io_error_$cannot_position);
	     end;

set_BOR_store_op_and_return:				/* current operation positions to Beginning Of a Record */
	file_desc.newline_needed = "0"b;

store_op_and_return:				/* All logic, except closing a file, terminates here. */
	if file_desc.connected
	then file_desc.previous = current;		/* The operation type is stored for further use. */
	else file_desc.previous = 0;			/*  Force subsequent READ or WRITE to open first.  */
	return;

/*  The implementation of ENDFILE is tricky for several reasons:             */
/*                                                                           */
/*  (1) It can be applied to a file which is not connected, in which case we */
/*      must perform an implicit association.  We cannot perform an implicit */
/*      connection via the 'implicit_open' routine, since we have no way to  */
/*      discover the form of the file.  Moreover, we may not even be able to */
/*      associate the file correctly, if the I/O module allows both stream   */
/*      and sequential openings.                                             */
/*                                                                           */
/*  (2) The Standard says that ENDFILE must appear to produce a record as    */
/*      far as BACKSPACE is concerned.  Thus we must keep a count of the     */
/*      "unwritten" EOF records for I/O modules that do not support EOF      */
/*      records (i.e. all standard I/O modules other than 'tape_nstd_').     */
/*                                                                           */
/*  (3) The Standard says that ENDFILE must alter the file so that only the  */
/*      records preceeding the ENDFILE are retained.  This means that we     */
/*      must disallow ENDFILE if the I/O module does not support truncation, */
/*      as is the case with 'tape_mult_' and 'tty_'.                         */

action (7):					/*  ENDFILE  */
	dcl     switch_for_endfile	 char (6) aligned,
	        unit_for_endfile	 pic "99";

	if file_desc.unwritten_eofs > 0
	then if file_desc.unwritten_eofs < Max_unwritten_eofs
	     then file_desc.unwritten_eofs = file_desc.unwritten_eofs + 1;
	     else call print_error (fortran_io_error_$cannot_truncate, me, "More than ^i successive ENDFILEs.",
		     Max_unwritten_eofs);
	else do;					/*  Try to write or simulate an EOF record.  */
		if file_desc.connected
		then do;				/*  Check that ENDFILE is allowed.  */
			if ^file_desc.allow.positioning
			then call print_error (fortran_io_error_$cannot_truncate);
			if file_desc.out
			then do;
				call finish_line;
				if my_code ^= 0
				then call print_error (my_code);
			     end;
			else if file_desc.allow_reopen
			then call reopen_for_output;
			else call print_error (fortran_io_error_$cannot_truncate);
		     end;
		else file_desc.out = TRUE;		/*  Ensure subsequent connection allows output.  */
		if ^file_desc.switch_ready
		then do;				/*  Implicitly associate the unit.  */
			unit_for_endfile = fio_ps.file_number;
			switch_for_endfile = "file" || unit_for_endfile;
			call iox_$find_iocb (switch_for_endfile, iocb_ptr, my_code);
			if my_code ^= 0
			then call print_error (my_code, me, "Cannot get iocb for ^a.", switch_for_endfile);
			if iocb_ptr -> iocb.attach_descrip_ptr = null
			then do;			/*  Attach unit to disk file of same name as switch.  */
				call iox_$attach_iocb (iocb_ptr, "vfile_ " || switch_for_endfile, my_code);
				if my_code ^= 0
				then call print_error (my_code, me, switch_for_endfile);
				file_desc.fortran_attached = TRUE;
			     end;
			else if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_"
			then do;			/*  'tape_nstd_' is special:  it really has EOF records.  */
				file_desc.switch_ready = TRUE;
						/*  Must maintain the association till connection.  */
				file_desc.eofs_are_records = TRUE;
				file_desc.switch_p = iocb_ptr;
			     end;
			if iocb_ptr -> iocb.open_descrip_ptr = null
			then do;			/*  Open the unit for stream or sequential output.  */
				call iox_$open (iocb_ptr, 2, ""b, my_code);
						/*  Try stream output.  */
				if my_code ^= 0
				then call iox_$open (iocb_ptr, 5, ""b, my_code);
						/*  Try sequential output.  */
				if my_code ^= 0
				then call print_error (my_code, me, switch_for_endfile);
				file_desc.fortran_opened = TRUE;
			     end;
		     end;

		call iox_$control (iocb_ptr, "write_eof", null, my_code);
		if my_code ^= 0
		then do;				/*  EOF records not supported -- try to simulate.  */
			if file_desc.previous ^= 1
			then do;			/*  Truncate if last op not WRITE.  */
				call iox_$control (iocb_ptr, "truncate", null, my_code);
				if my_code ^= 0
				then call print_error (fortran_io_error_$cannot_truncate);
			     end;
			if fio_ps.ansi_77
			then file_desc.unwritten_eofs = 1;
		     end;

		if file_desc.fortran_opened & ^file_desc.switch_ready
		then do;				/*  Close the file in case we opened in wrong mode.  */
			call iox_$close (iocb_ptr, my_code);
			file_desc.fortran_opened = FALSE;
		     end;
	     end;
	goto set_BOR_store_op_and_return;

action (15):					/* openfile */
	if ^fast_related_data_$in_dfast
	then goto not_supported;
	call dfast_openfile;
	goto store_op_and_return;

action (16):					/* open */
	call open_statement;
	goto store_op_and_return;

action (17):					/* margin */
	if ^fast_related_data_$in_dfast
	then goto not_supported;

	call set_max_recl (max_recl);
	return;					/* use of margin is not recorded as previous operation */

not_supported:
	call ioa_$ioa_switch (iox_$error_output, "Warning: ^a (on file ^d) is not supported in Multics or FAST.
	The statement is ignored.", operation_name (current), fio_ps.file_number);
	return;


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

/* These two entries are called by the various I/O processing entries to perform additional data transfers as
   required.  read_a_record is called only if the input transfer requires more than one record.
   write_a_record must be called each time a record is to be output. */



read_a_record:
     entry;

	if fio_ps.mode = string_io | fio_ps.mode = internal_file
	then do;
		buffer_pointer = add_char_offset_ (buffer_pointer, char_offset);
		if fio_ps.mode = internal_file
		then do;				/*  Check for EOF.  */
			internal_file_count = internal_file_count - 1;
			if internal_file_count <= 0
			then goto end_of_file;
		     end;
		return;
	     end;

read_a_record_label:
	buffer_length = buffer_max_len;		/* get maximum buffer length */
	fio_ps.have_input = "0"b;			/* record is undefined till after the read */

/* Position to record if required */

	if fio_ps.mode = direct_access
	then call get_record (exists);		/* output value is ignored */

/* Now, read */

	if file_desc.type_of_io = stream_file
	then do;

/* special processing for terminals */

		if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io
		then do;
			if interactive
			then fortran_buffer_.terminal_needs_newline = "0"b;

/* output prompt_character if required */

			if file_desc.prompt
			then do;
				call iox_$put_chars (iox_$user_io, addr (prompt_char), 2, my_code);
				if my_code ^= 0
				then call print_error (my_code);
			     end;
		     end;

		call iox_$get_line (iocb_ptr, buffer_pointer, buffer_length, sent, my_code);

/* remove newline from record if present */

		if my_code = 0
		then sent = sent - 1;

		else if my_code = error_table_$short_record
						/* record does not end with newline */
		then my_code = 0;

/* special end-of-file for formatted sequential stream files */

		if file_desc.carriage_controllable
		then do;
			if sent = length (EOF1)
			then if substr (io_buf, 1, length (EOF1)) = EOF1
			     then goto end_of_file;
			     else ;
			else if sent = length (EOF2)
			then if substr (io_buf, 1, length (EOF2)) = EOF2
			     then goto end_of_file;
			     else if substr (io_buf, 1, length (EOF3)) = EOF3
			     then do;
end_of_file:					/* If user provided iostat var, set it; and if end= is not supplied then return. */
				     if fio_ps.ansi_77
				     then if my_code = error_table_$end_of_info & ^file_desc.eofs_are_records
					then if file_desc.unwritten_eofs = 0
					     then file_desc.unwritten_eofs = 1;
						/*  Remember we hit EOI.  */
					     else call print_error (fortran_io_error_$read_after_eof);
				     if fio_ps.iostat_var
				     then do;
					     PS.iostat_p -> words (1) = -error_table_$end_of_info;
						/*  Standard requires negative code for EOF.  */
					     if ^fio_ps.end_label
					     then goto return_error_code;
					end;

				     if fio_ps.end_label
						/* return to user if end= specified */
				     then call return_to_user (PS.end_p, PS.stack_frame_p);

/* Prevent err= transfer for EOF unless direct_access. */

				     if fio_ps.mode ^= direct_access
				     then fio_ps.error_label = "0"b;

				     fio_ps.have_input = "0"b;
						/* if EOF then nothing to print */
				     if fio_ps.mode = internal_file
				     then call internal_file_overflow;
				     else call print_error (error_table_$end_of_info);
				end;
		     end;				/* formatted end of file */

		file_desc.newline_needed = "0"b;	/* in case write follows */
	     end;

	else if file_desc.type_of_io = record_file | file_desc.type_of_io = blocked_file
	then do;
		call iox_$read_record (iocb_ptr, buffer_pointer, buffer_length, sent, my_code);
	     end;

	else if file_desc.type_of_io = binary_file
	then do;

/* If there is an I/O list, data is read directly from the device into each item on demand.
		If there is no list, one "record" (single word or double word) is read and discarded. */

		if ^fio_ps.list
		then do;
			fio_ps.element_p = buffer_pointer;
						/* need a place to put data; it will be discarded */

			if file_desc.double_word_file /* get default length */
			then buffer_length = CPDW;
			else buffer_length = CPW;
		     end;

		else if call_sw < 0			/* do nothing on first call if there is a list */
		then do;
			buffer_length = 0;		/* Nothing read. */
			my_code = 0;		/* No errors occurred. */
			return;
		     end;

		else do;				/* get char len of item */
			buffer_length = fio_ps.element_count;
		     end;

		if ^fio_ps.element_desc.VLA
		then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code);
		else do;
			chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1;
			if buffer_length <= chars_left
			then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code);
			else do;			/*  Target crosses into next VLA component.  */
				call iox_$get_chars (iocb_ptr, fio_ps.element_p, chars_left, sent, my_code);
				if my_code = 0
				then do;
					call iox_$get_chars (iocb_ptr,
					     baseptr (fixed (baseno (fio_ps.element_p)) + 1),
					     buffer_length - chars_left, sent, my_code);
					sent = sent + chars_left;
				     end;
			     end;
		     end;

		if my_code ^= 0
		then if my_code = error_table_$short_record
						/* i.e., less data returned than requested. */
		     then goto end_of_file;		/* Some data was not returned. */
	     end;

	if my_code ^= 0
	then if my_code = error_table_$end_of_info
	     then go to end_of_file;
	     else call print_error (my_code);


	buffer_length = sent;
	fio_ps.have_input = fio_ps.format ^= unformatted; /* i.e., fmt, namelist, or list-dir */
	return;


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

/* called to output a record to the I/O module. */

write_a_record:
     entry;

/* NOTE - Some code directly relating to output has been moved to action(3) in the in the main body of this
   internal procedure. The code was moved so as to remove a test from the write loop.
   For internal_files, blank out remainder of record if the format is insufficiently long (buffer_length < buffer_max_len)
   and on terminate call (call_sw = 1), pad with blanks if there is any unflushed buffer.
   Decrement the internal_file_count each time, when it hits zero, set buffer_max_len to zero, so expand_buffer will prevent 
   the writing of the next record, as it is impossible to know if the next reocrd is going to be written.
   We can detect an error if there has been an attemp to write a zero_length record, as internal_file_count will go negative.
   Do not make this check on terminate call.
*/

	if fio_ps.mode = string_io | fio_ps.mode = internal_file
	then do;
		if fio_ps.mode = internal_file
		then do;
			if buffer_max_len > buffer_length
			then if call_sw < 1 | buffer_length > 0
			     then substr (buffer_pointer -> chars, buffer_length + 1,
				     buffer_max_len - buffer_length) = SP;
			internal_file_count = internal_file_count - 1;
			if internal_file_count = 0
			then buffer_max_len = -1;
			else if internal_file_count < 0 & call_sw <= 0
			then call internal_file_overflow;
		     end /* internal_file only */;

		buffer_length = 0;
		buffer_pointer = add_char_offset_ (buffer_pointer, char_offset);
		return;
	     end;

/*  Check for WRITE after EOF record.  */

	if file_desc.unwritten_eofs > 0
	then if ^file_desc.carriage_controllable
	     then call print_error (fortran_io_error_$write_after_eof);
	     else do;				/*  Write appropriate number of EOF records.  */
		     call finish_line;
		     if my_code ^= 0
		     then call print_error (my_code);
		     do while (file_desc.unwritten_eofs > 0);
			call iox_$put_chars (iocb_ptr, addr (EOF1), length (EOF1), my_code);
			if my_code = 0
			then call iox_$put_chars (iocb_ptr, addr (NL), length (NL), my_code);
			if my_code ^= 0
			then call print_error (my_code);
			file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1;
		     end;
		end;

/* Special processing for formatted records */

	if file_desc.formatted_records
	then do;

/* state of the terminal is maintained elsewhere; copy it. */

		terminal_file = iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io;

		if terminal_file
		then do;
			file_desc.newline_needed = fortran_buffer_.terminal_needs_newline;
			fortran_buffer_.terminal_needs_newline = file_desc.defer_newline;
		     end;

/*  IF REQUIRED, CONVERT CARRIAGE CONTROL CHAR TO SLEW CHAR OR ADD NEWLINE CHAR */

		if file_desc.carriage_controllable	/* ="1"b if file contain newline chars */
		then if file_desc.printer_file	/* File requires CC char conversion. */
		     then if column_one = buffer_length
			then do;			/* a blank line */
				if column_one = 0 & ^file_desc.newline_needed
				then if terminal_file
				     then fortran_buffer_.terminal_needs_newline = "1"b;
				     else file_desc.newline_needed = "1"b;
				else do;
					buffer_length = buffer_length + 1;
					substr (io_buf, buffer_length, 1) = NL;
				     end;
			     end;

			else if substr (io_buf, column_one + 1, 1) = SP
						/* Most common CC char. */
			then goto single_space;

			else if substr (io_buf, column_one + 1, 1) = "0"
			then do;			/* Double space. */
				if column_one = 0
				then if file_desc.newline_needed
				     then do;	/* first record, no need to move text. */
					     buffer_pointer = addr (fortran_buffer_.extra_char);
					     buffer_length = buffer_length + 1;
					     substr (io_buf, 1, 2) = two_NLs;
					end;
				     else substr (io_buf, 1, 1) = NL;
				else do;
					if buffer_length - column_one - 1 > 0
						/* i.e., text follows CC char */
					then substr (io_buf, column_one + 3, buffer_length - column_one - 1) =
						copy (
						substr (io_buf, column_one + 2,
						buffer_length - column_one - 1), 1);
					substr (io_buf, column_one + 1, 2) = two_NLs;
					buffer_length = buffer_length + 1;
				     end;
			     end;			/* double space */

			else if substr (io_buf, column_one + 1, 1) = "1"
			then do;			/* Slew to top of next page. */
				if column_one = 0
				then if file_desc.newline_needed
				     then do;	/* first record, no need to move text. */
					     buffer_pointer = addr (fortran_buffer_.extra_char);
					     buffer_length = buffer_length + 1;
					     substr (io_buf, 1, 2) = NL_FF;
					end;
				     else substr (io_buf, 1, 1) = FF;
				else do;
					if buffer_length - column_one - 1 > 0
						/* i.e., text follows CC char */
					then substr (io_buf, column_one + 3, buffer_length - column_one - 1) =
						copy (
						substr (io_buf, column_one + 2,
						buffer_length - column_one - 1), 1);
					substr (io_buf, column_one + 1, 2) = NL_FF;
					buffer_length = buffer_length + 1;
				     end;
			     end;			/* top of page */

			else if substr (io_buf, column_one + 1, 1) = "+"
			then do;			/* Overprint on previous record. */
				if column_one = 0 & ^file_desc.newline_needed
				then do;		/* too late, newline already printed */
					buffer_length = buffer_length - 1;
					buffer_pointer = addr (substr (io_buf, 2, 1));
				     end;
				else substr (io_buf, column_one + 1, 1) = CR;
			     end;			/* overprint */

			else do;			/* Single space. */
single_space:
				if column_one = 0 & ^file_desc.newline_needed
				then do;
					buffer_length = buffer_length - 1;
					buffer_pointer = addr (substr (io_buf, 2, 1));
				     end;
				else substr (io_buf, column_one + 1, 1) = NL;
			     end;			/* single space */

/* Add newline for files without carriage control */

		     else do;
			     if column_one = 0 & file_desc.newline_needed
			     then do;
				     buffer_length = buffer_length + 1;
				     buffer_pointer = addr (fortran_buffer_.extra_char);
				     fortran_buffer_.extra_char = NL;
				end;

			     if call_sw <= 0
			     then do;
				     substr (io_buf, buffer_length + 1, 1) = NL;
				     buffer_length = buffer_length + 1;
				end;
			end;
	     end;					/* code for formatted records */


/* perform record positioning if required */

	if fio_ps.mode = direct_access
	then do;
		call get_record (exists);
	     end;
	else exists = "0"b;

/* write the record */

	if file_desc.type_of_io = stream_file
	then goto write_stream;

	else if file_desc.type_of_io = record_file
	then do;
		if file_desc.using_tape_nstd & (mod (buffer_length, 4) ^= 0)
		then do;
			new_buffer_length = buffer_length + 4 - mod (buffer_length, 4);

/* pad with spaces for formatted records; pad with null bytes otherwise. */

			if file_desc.formatted_records
			then substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = " ";
			else substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = low (1);
			buffer_length = new_buffer_length;
		     end;
		if ^exists
		then call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code);
		else call iox_$rewrite_record (iocb_ptr, buffer_pointer, buffer_length, my_code);
		buffer_length = 0;
	     end;

	else if file_desc.type_of_io = blocked_file
	then do;
		if my_code = error_table_$end_of_info
		then call print_error (my_code);	/* file probably attached without -no_end option */
		call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code);
		buffer_length = 0;
		if my_code = 0 & fio_ps.mode = sequential_access & file_desc.open_code = Sequential_update
		then call iox_$control (iocb_ptr, "truncate", null, my_code);
	     end;

	else do;
write_stream:
		if call_sw > 0			/* i.e., last call */
		then do;

/* If file contains newline chars, one more may be needed. */

			if file_desc.carriage_controllable
						/* i.e., does file have newline chars? */
			then if ^file_desc.defer_newline
						/* yes, and they are not deferred */
			     then if suppress_final_newline
				then ;
				else do;
					substr (io_buf, buffer_length + 1, 1) = NL;
						/* so put final newline char in */
					buffer_length = buffer_length + 1;
					if terminal_file
						/* reset need for initial newline char */
					then fortran_buffer_.terminal_needs_newline = "0"b;
					else file_desc.newline_needed = "0"b;
				     end;
			     else if ^file_desc.newline_needed
			     then file_desc.newline_needed = "1"b;

			call iox_$put_chars (iocb_ptr, buffer_pointer, buffer_length, my_code);
			column_one = 0;
		     end;

		else do;				/* Write text later; just update virtual origin */
			column_one = buffer_length;
			my_code = 0;		/* "write call" was successful */
		     end;
	     end;

	if my_code ^= 0
	then call print_error (my_code);

	return;

validate_mode_and_access:
     proc;					/* compare mode and access of request to that of the file */

/* CHECK MODE - input or output */

	if fio_ps.read
	then if ^file_desc.in
	     then if ^file_desc.allow_reopen
		then call print_error (fortran_io_error_$cannot_read);
		else call reopen_for_input;
	     else ;				/* file is already open for input */

	else if ^file_desc.out
	then if ^file_desc.allow_reopen
	     then call print_error (fortran_io_error_$cannot_write);
	     else call reopen_for_output;


/* CHECK ACCESS - sequential or direct */

	if fio_ps.mode = direct_access
	then if ^file_desc.allow.direct_access
	     then call print_error (fortran_io_error_$not_direct);
	     else ;				/* file does support it */
	else if ^file_desc.allow.seq_access
	then call print_error (fortran_io_error_$not_sequential);


/* CHECK FORM - formatted or unformatted */

	if fio_ps.format = unformatted
	then if file_desc.formatted_records
	     then call print_error (fortran_io_error_$formatted_file);
	     else ;				/* they match */
	else if ^file_desc.formatted_records
	then call print_error (fortran_io_error_$unformatted_file);
     end validate_mode_and_access;


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

get_record:
     proc (record_found);

	dcl     record_found	 bit (1) aligned;
	dcl     record_key		 picture "99999999";
	dcl     record_length	 fixed bin (21);

/* is record number in range ? */

	if PS.record_number < 0 | PS.record_number > 99999999
	then call print_error (error_table_$no_record);

	file_desc.last_rec = PS.record_number;
	record_found = "1"b;			/* Reset only if I/O module cannot find the record. */

/* position the file. */

	if file_desc.type_of_io = record_file
	then do;
		record_key = PS.record_number;	/* convert number to character string */

		call iox_$seek_key (iocb_ptr, (record_key), record_length, my_code);
		if my_code ^= 0
		then if my_code = error_table_$no_record
		     then record_found = "0"b;
	     end;

	else if file_desc.type_of_io = blocked_file
	then do;

/* vfile_ really should support a seek_key operation for
	        blocked files.  Since it doesn't, we must use
	        record_status to locate a record for read (in order to
	        tell us if a record has been deleted) and iox_$position for
	        write (because record_status has a bug talking about records
	        located by seek_key having been deleted by another opening).  */

		if fio_ps.read
		then do;
			rs_info_ptr = addr (info);
			unspec (rs_info) = "0"b;
			rs_info.version = rs_info_version_2;
			rs_info.flags.locate_pos_sw = "1"b;
			rs_info.record_length = PS.record_number;
			call iox_$control (iocb_ptr, "record_status", rs_info_ptr, my_code);
			if my_code ^= 0
			then if my_code = error_table_$no_record | my_code = error_table_$asynch_deletion
			     then record_found = "0"b;
		     end;

		else do;
			call iox_$position (iocb_ptr, 2, (PS.record_number), my_code);
			if my_code ^= 0
			then record_found = "0"b;
		     end;
	     end;

	else if file_desc.type_of_io = binary_file
	then do;
		call iox_$position (iocb_ptr, 2, PS.record_number * CPW, my_code);
	     end;

	else do;					/* double binary */
		call iox_$position (iocb_ptr, 2, PS.record_number * CPDW, my_code);
	     end;

	PS.record_number = PS.record_number + 1;

	if my_code ^= 0
	then if fio_ps.read | record_found
	     then do;				/* Convert error code if it may not be helpful. */

		     if my_code = error_table_$no_record/* Record not found. */
		     then ;
		     else if my_code = error_table_$end_of_info
						/* Record number is too large. */
		     then ;
		     else if my_code = error_table_$asynch_deletion
		     then my_code = error_table_$no_record;
		     else my_code = fortran_io_error_$not_direct;
						/* Assume I/O module complained about order call. */

		     call print_error (my_code);
		end;

     end get_record;

     end initialize_fortran_io;

set_max_recl:
     proc (maxl);

	dcl     maxl		 fixed bin;

	info (1) = -1;				/* vfile_ returns old value here */
	info (2) = maxl;
	call iox_$control (iocb_ptr, "max_rec_len", addr (info), my_code);

	if my_code ^= 0
	then if my_code ^= error_table_$no_operation
	     then call print_error (fortran_io_error_$not_blocked);

	     else if info (1) < 0			/* file does not have max rec len */
	     then call print_error (fortran_io_error_$not_blocked);

	     else if info (1) ^= info (2)		/* file is not empty or not open for output */
	     then if open_mode (file_desc.open_code).out
		then call print_error (fortran_io_error_$must_be_empty);
		else call print_error (fortran_io_error_$cannot_write, me,
			"A file must be opened for output in order to change its maximum record length.");

	     else ;				/* old recl is the same; therefore no operation */

     end set_max_recl;


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

strip_line_no:
     proc;					/* Removes line no, a field of digits, from the beginning of a record */

	dcl     ln		 fixed bin;

	if length (rest_of_record) = 0
	then
ln_error:
	     call print_error (fortran_io_error_$syntax_error, me, "No line number on this line.");

	ln = verify (rest_of_record, "0123456789") - 1;

	if ln < 0					/* all digits */
	then do;
		buffer_index = buffer_index + length (rest_of_record);
		last = buffer_index;
		return;
	     end;

	else if ln = 0				/* no digits */
	then goto ln_error;

	buffer_index = buffer_index + (ln + 1);		/* skip digits plus one character */
	last = buffer_index;
     end strip_line_no;

dfast_openfile:
     proc ();

	dcl     filetypes		 char (36) int static options (constant)
				 init ("ter pri str bin rec raw num dnu key ");

	in = divide (index (filetypes, translate (substr (filetype_ptr -> chars, 1, 3), lower_letters, capital_letters))
	     + 3, 4, 17, 0);

	if in = 0
	then call print_error (fortran_io_error_$unknown_filetype, me, """^a""", substr (filetype_ptr -> chars, 1, 3));

	if fio_ps.file_number = 0
	then do;
		if in = 1				/* terminal */
		then file_desc.printer_file = "0"b;

		else if in = 2			/* print */
		then file_desc.printer_file = "1"b;

		else call print_error (fortran_io_error_$invalid_file0_type);
		return;
	     end;

	if file_desc.connected
	then call close_fortran_file;

	unspec (fortran_open_data.specified) = "0"b;

	fortran_open_data.specified.attach_desc = "1"b;
	fortran_open_data.specified.form = "1"b;
	fortran_open_data.specified.mode = "1"b;
	fortran_open_data.specified.access = "1"b;
	fortran_open_data.specified.prompt = "1"b;
	fortran_open_data.specified.carriage = "1"b;
	fortran_open_data.specified.defer = "1"b;

	string (fortran_open_data.specified.direction) = "11"b;
	fortran_open_data.specified.dfast_openfile = "1"b;

	fortran_open_data.prompt = "0"b;
	fortran_open_data.carriage = "0"b;
	fortran_open_data.defer = "0"b;

	fortran_open_data.attach_desc.offset = 0;

/* Build an attach description to support the desired file type. */

	fortran_open_data.char_str = "vfile_ ";

	fortran_open_data.char_str =
	     fortran_open_data.char_str || rtrim (substr (pathname_ptr -> chars, 1, PS.max_buffer));

	goto convert_dfast_file (in);


convert_dfast_file (1):				/* terminal */
	fortran_open_data.formatted_records = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -append";
	in = unstructured;
	goto finish_dfast_open;


convert_dfast_file (2):				/* print */
	fortran_open_data.carriage = "1"b;
	fortran_open_data.formatted_records = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -append";
	in = unstructured;
	goto finish_dfast_open;


convert_dfast_file (3):				/* string */
	fortran_open_data.direct_access = "1"b;
	fortran_open_data.formatted_records = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12";
	in = blocked;
	goto finish_dfast_open;


convert_dfast_file (4):				/* binary */
	fortran_open_data.direct_access = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12";
	in = blocked;
	goto finish_dfast_open;


convert_dfast_file (5):				/* record */
	fortran_open_data.char_str = fortran_open_data.char_str || " -append";
	in = sequential;
	goto finish_dfast_open;


convert_dfast_file (6):				/* raw */
	fortran_open_data.direct_access = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -no_trunc";
	in = binary_stream;
	goto finish_dfast_open;


convert_dfast_file (7):				/* numeric */
	fortran_open_data.direct_access = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -header 1";
	in = binary_stream;
	goto finish_dfast_open;


convert_dfast_file (8):				/* dnumeric */
	fortran_open_data.direct_access = "1"b;

	fortran_open_data.char_str = fortran_open_data.char_str || " -header 2";
	in = binary_stream;
	goto finish_dfast_open;


convert_dfast_file (9):				/* keyed */
	fortran_open_data.formatted_records = "1"b;

	in = indexed;


finish_dfast_open:
	fortran_open_data.char_str = fortran_open_data.char_str || " -ssf";

	fortran_open_data.attach_desc.length = length (fortran_open_data.char_str);

	call open_fortran_file (in);
     end dfast_openfile;

open_statement:
     proc;					/* code for open and close statements */

	dcl     allow_default	 bit (1) aligned;
	dcl     desired_file_type	 fixed bin;
	dcl     desired_type	 fixed bin;
	dcl     erasable_file	 bit (1) aligned;
	dcl     file		 picture "99";
	dcl     file_is_empty	 bit (1) aligned;
	dcl     file_name		 (-1:6) char (12) int static options (constant)
				 init ("undefined", "nonexistent", "unstructured", "sequential", "blocked",
				 "indexed", "binary", "non vfile_");
	dcl     keep_status		 fixed bin;
	dcl     fio_vfile_attach	 bit (1) aligned;
	dcl     i			 fixed bin;
	dcl     implicit_opening	 bit (1) aligned;
	dcl     job_index		 fixed bin;
	dcl     len		 fixed bin;
	dcl     nstd_opening	 (13) fixed bin int static options (constant)
				 init (1, 4, 8, 11, 6, 7, 5, 3, 2, 10, 9, 13, 12);
	dcl     off		 fixed bin;
	dcl     offset_for_direct_access
				 fixed bin int static options (constant) init (2);
	dcl     offset_for_out_mode	 fixed bin int static options (constant) init (4);
	dcl     open_index		 fixed bin;
	dcl     using_vfile		 bit (1) aligned;


	dcl     1 nstd		 aligned structure int static options (constant),
		2 first		 (8) fixed bin (17) init (1, 2, 3, 3, 5, 5, 10, 10),
		2 last		 (8) fixed bin (17) init (2, 2, 4, 4, 9, 7, 13, 13);

/* format: off */
	dcl     file_type_matrix	 (-1:5, -1:5) fixed bin int static options (constant)		 

init (/*    desired	   	         actual */

		 /*	 und ^ex uns seq blo ind bin */
          /* und */		  0,  0,  1,  2,  3,  4,  5,
	/* ^ex */		  0,  0,  1,  2,  3,  4,  5,
	/* uns */		  1,  1,	1,  2,  3,  4,  5,
	/* seq */		  2,  2,	2,  2, -1, -1, -1,
	/* blo */		  3,  3, -1, -1,  3, -1, -1,
	/* ind */		  4,  4, -1, -1, -1,  4, -1,
	/* bin */		  5,  5,	5, -1, -1, -1,  5);

	dcl     opening		 (8, 0:5) fixed bin int static
				 options (constant)
 /* bounds depend on job_index and file_type */

		 init (/*		  n   u   s   b   i   b */
		 /*		  o   n   e   l   n   i */
		 /*		  n   s   q   o   d   n */
		 /*		  e   t   u   c   e   a */
		 /*		  x   r   e   k   x   r */
		 /*		  i   u   n   e   e   y */
		 /*		  s   c   t   d   d     */

/*  in seq fmt */			  1,  1,	4,  4,  4,  0,
/*  in seq unf */			  4,  0,	4,  4,  4,  1,
/*  in D/A fmt */			  8,  0,	0,  4,  8,  0,	
/*  in D/A unf */			  8,  0,	0,  4,  8,  1,
/* out seq fmt */			  3,  3,	6,  7,  0,  0,
/* out seq unf */			  6,  0,	6,  7,  0,  3,
/* out D/A fmt */			 10,  0,	0,  7, 10,  0,
/* out D/A unf */			 10,  0,	0,  7, 10,  3);

/* format: on */

/* procedure to open a fortran file regardless how the open is requested. Currently, there
	   are three methods, implicitly by a read or write statement, explicitly by the open
	   statement, and explicitly by the dfast openfile statement. */

/* open statement */


/* PROCESS FIELDS SUPPLIED BY THE USER */

	if fortran_open_data.specified.status
	then do;
		call convert_from_character (status_field, open_status_values, i);
		fortran_open_data.file_status = i - 1;
	     end;
	else fortran_open_data.file_status = unknown_file;/* default value */

	if fortran_open_data.specified.mode
	then do;
		call convert_from_character (mode_field, open_mode_values, i);

		if i = 1				/* value is "in" */
		then string (fortran_open_data.direction) = "10"b;
		else if i = 2			/* value is out */
		then string (fortran_open_data.direction) = "01"b;
		else string (fortran_open_data.direction) = "11"b;
						/* inout */
	     end;
	else string (fortran_open_data.direction) = "11"b;/* default is "inout" */

	if fortran_open_data.specified.access
	then do;
		call convert_from_character (access_field, open_access_values, i);
		if i = 2				/* 1 is sequential, 2 direct */
		then fortran_open_data.direct_access = "1"b;
	     end;

	if fortran_open_data.specified.form
	then do;
		call convert_from_character (form_field, open_form_values, i);

		if i = 1				/* 1 is formatted, 2 unformatted */
		then fortran_open_data.formatted_records = "1"b;
	     end;

	if fortran_open_data.specified.blank
	then do;
		call convert_from_character (blank_field, open_blank_values, i);
		fortran_open_data.blank_null = (i = 1); /* 1 is null , 2 zero */
	     end;
	else fortran_open_data.blank_null = fio_ps.ansi_77;
						/* default to zero iff ansi66 */

/* CHECK open statement conflicts */

	if fortran_open_data.specified.recl & fortran_open_data.specified.binary & fortran_open_data.binary
	then call print_error (fortran_io_error_$open_attr_conflict, me, "Binary stream and recl.");

	if fortran_open_data.specified.filename
	then do;

		if fortran_open_data.specified.attach_desc
		then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and file.");

		call exists_file (exists_file_code);
		if exists_file_code = 1
		then call print_error (error_table_$pathlong, me, "A filename may not be longer than 168 characters.")
			;
		else if exists_file_code = 2
		then call print_error (fortran_io_error_$open_attr_incomplete, me,
			"A non-blank filename is required.");

	     end;

/* The STATUS= specifier is ignored in ansi66 program units. */

	if fio_ps.ansi_77
	then do;

/* If status = "scratch",
    	no "file=" specifier can be used. */

		if fortran_open_data.specified.filename & fortran_open_data.file_status = scratch_file
		then call print_error (fortran_io_error_$open_attr_conflict, me, "File and status = ""scratch"".");

/* If status = "old",
	a "file=" specifier must be present in the open statement and 
	the named file must exist. */

		if fortran_open_data.file_status = old_file
		then do;
			if ^fortran_open_data.specified.filename
			then call print_error (fortran_io_error_$open_attr_incomplete, me,
				"A filename is required for status = ""old"".");
			else if exists_file_code = 3
			then call print_error (error_table_$noentry, me, "The file must exist if status = ""old"".")
				;
		     end;

/* If status = "new",
    	a "file=" specifier must be present in the open statment, but
 	the named file cannot exist already. */

		else if fortran_open_data.file_status = new_file
		then do;
			if ^fortran_open_data.specified.filename
			then call print_error (fortran_io_error_$open_attr_incomplete, me,
				"A filename is required for status = ""new"".");
			else if exists_file_code = 0
			then call print_error (fortran_io_error_$status_field_error, me,
				"The file must not exist if status = ""new"".");
		     end;

/* If status = "append",
          the access control must be "sequential",
	no attach description may be present,
	no io_switch name may be present. */

		else if fortran_open_data.file_status = append_file
		then do;

			if fortran_open_data.direct_access
			then call print_error (fortran_io_error_$open_attr_conflict, me,
				"Access = ""direct"" and status = ""append"".");

			if fortran_open_data.specified.binary & fortran_open_data.binary
			then call print_error (fortran_io_error_$open_attr_conflict, me,
				"Binary stream and status = ""append"".");

			if fortran_open_data.specified.attach_desc
			then call print_error (fortran_io_error_$open_attr_conflict, me,
				"Attach and status = ""append"".");

			if fortran_open_data.specified.io_switch
			then call print_error (fortran_io_error_$open_attr_conflict, me,
				"Ioswitch and status = ""append"".");

		     end;

	     end;

	desired_file_type = undefined;
	implicit_opening = "0"b;
	goto open_common;


implicit_open:
     entry;

	unspec (fortran_open_data.specified) = "0"b;

	fortran_open_data.specified.form = "1"b;
	fortran_open_data.specified.mode = "1"b;
	fortran_open_data.specified.access = "1"b;

	fortran_open_data.direction.out = file_desc.direction.out;
						/* Sets 'out' if an ENDFILE has occurred. */
	if fio_ps.read
	then fortran_open_data.direction.in = "1"b;
	else fortran_open_data.direction.out = "1"b;

	if fio_ps.mode = direct_access
	then fortran_open_data.direct_access = "1"b;

	if fio_ps.format ^= unformatted
	then fortran_open_data.formatted_records = "1"b;

	desired_file_type = undefined;
	implicit_opening = "1"b;
	goto open_common;


open_fortran_file:
     entry (desired_type);

	desired_file_type = desired_type;		/* caller supplies desired type */
	implicit_opening = "0"b;

open_common:
	if implicit_opening				/* already done for open statement */
	then fortran_open_data.blank_null = fio_ps.ansi_77;

	if fio_ps.file_number = 0			/* Process file 0 separately. */
	then do;
		if fortran_open_data.specified.status | fortran_open_data.specified.io_switch
		     | fortran_open_data.specified.attach_desc | fortran_open_data.specified.filename
		     | fortran_open_data.specified.mode | fortran_open_data.specified.access
		     | fortran_open_data.specified.form | fortran_open_data.specified.recl
		     | fortran_open_data.specified.binary
		then do;
			call print_error (fortran_io_error_$invalid_file0_attr);
			return;
		     end;

		if fortran_open_data.specified.prompt
		then file_desc.prompt = fortran_open_data.prompt;

		if fortran_open_data.specified.carriage
		then file_desc.printer_file = fortran_open_data.carriage;

		if fortran_open_data.specified.defer
		then file_desc.defer_newline = fortran_open_data.defer;

		file_desc.blank_null = fortran_open_data.blank_null;
		return;
	     end;					/* file 0 */


/* begin open code */

	file = fio_ps.file_number;			/* convert file number to character in case is needed */
	uns_info.type = undefined;			/* to prevent erroneous use of the structure */

	erasable_file,				/* accumulates the condition: attached and opened by FIO */
	     file_is_empty,				/* Assume a non-empty file. */
	     using_vfile,				/* Assume I/O switch is not vfile_. */
	     fio_vfile_attach = "0"b;			/* ="1"b if fio creates a vfile_ attach desc */
	fortran_buffer_.all_files_closed = "0"b;	/* file table is modified */


/* SET FILE TYPE ATTRIBUTES AS REQUIRED */

	if fortran_open_data.specified.recl
	then desired_file_type = blocked;

	if fortran_open_data.specified.binary & fortran_open_data.binary
	then desired_file_type = binary_stream;


/* FILE IS NOT CONNECTED; CONNECT IT */

	if ^file_desc.connected
	then do;					/* file is not connected yet */

/* File may be partially connected if last connection failed; it must be disconnected. */

		call close_fortran_file;		/* disconnects partially open file and zeros table entry */


/* GET IOCB NAME AND THEN IOCB PTR */

		if fortran_open_data.specified.io_switch
		then do;
			call get_open_field (io_switch_field, off, len);

			if len > length (ioname)
			then call print_error (field_error (io_switch_field), me,
				"I/O switch name is longer than ^d characters.", length (ioname));
			else if len < 1
			then call print_error (field_error (io_switch_field), me,
				"I/O switch name must be non-blank.");

			ioname = substr (fortran_open_data.char_str, off + 1, len);
		     end;

		else do;				/* use default I/O switch name */
			ioname = "file";
			substr (ioname, 5, 2) = file;
		     end;

		call iox_$find_iocb (ioname, iocb_ptr, my_code);
						/* get iocb pointer */

		if my_code ^= 0
		then do;
			call print_error (my_code, me, "Cannot get iocb for ^a.", ioname);
			return;
		     end;

		file_desc.switch_p = iocb_ptr;	/* Save in table for future use */


/* FILE IS NOT ATTACHED; ATTACH IT */

		if iocb_ptr -> iocb.attach_descrip_ptr = null
		then do;

/* the following determines if default attachment is possible */

			allow_default =
			     ^fortran_open_data.specified.io_switch /* attach and file also not allowed */
			     & ^fortran_open_data.direct_access & fortran_open_data.formatted_records
			     & string (fortran_open_data.direction) ^= "11"b & (desired_file_type = undefined);


/* CHOOSE AN ATTACH DESCRIPTION */

			if fortran_open_data.specified.attach_desc
						/* CASE: user supplies attach desc */
			then do;
				call get_open_field (attach_desc_field, off, attach_desc_len);

				if attach_desc_len > length (attachment)
				then call print_error (field_error (attach_desc_field), me,
					"Attach description is longer than ^d characters.", length (attachment))
					;
				else if attach_desc_len < 1
				then call print_error (field_error (attach_desc_field), me,
					"Attach description must be non-blank.");

				attachment = substr (fortran_open_data.char_str, off + 1, attach_desc_len);
			     end;

			else if fortran_open_data.specified.filename
						/* CASE: user supplies filename */
			then do;
				call get_open_field (filename_field, off, len);

				if len > length (attachment) - 7
				then call print_error (field_error (filename_field), me,
					"File name is longer than ^d characters.", length (attachment) - 7);
				else if len < 1
				then call print_error (field_error (filename_field), me,
					"File name must be non-blank.");

				substr (attachment, 1, 7) = "vfile_ ";
				substr (attachment, 8) = substr (fortran_open_data.char_str, off + 1, len);
				attach_desc_len = len + 7;

				using_vfile = "1"b; /* I/O module is vfile_ */
			     end;

/* CASE: default input */
			else if allow_default & file_desc.default_input & fortran_open_data.in
			then do;			/* file is default input */
				attachment = "syn_ user_input -inhibit put_chars";
				attach_desc_len = 34;

				uns_info.type = unstructured;
				implicit_opening = "0"b;
						/* KLUDGE - prevents mode from being input/output */
			     end;

/* CASE: default output */
			else if allow_default & file_desc.default_output & fortran_open_data.out
			then do;			/* file is default output */
				attachment = "syn_ user_output -inhibit get_line get_chars";
				attach_desc_len = 44;

				uns_info.type = unstructured;
				implicit_opening = "0"b;
						/* KLUDGE - prevents mode from being input/output */
			     end;

/* CASE: status = "scratch" */
			else if fortran_open_data.file_status = scratch_file
			then do;
				attachment =
				     "vfile_ " || rtrim (get_pdir_ ()) || ">file" || file || "."
				     || unique_chars_ (""b);

/* attach_desc_len is found after the SECOND blank, the first is after "vfile_" */
				attach_desc_len = index (substr (attachment, 8), SP) - 1;
				attach_desc_len = 7 + attach_desc_len;
				using_vfile = TRUE;
			     end;

/* CASE: FORTRAN I/O attachment */
			else do;
				attachment = "vfile_ file";
				substr (attachment, 12, 2) = file;
				attach_desc_len = 13;

				using_vfile = "1"b; /* I/O module is vfile_ */
			     end;


/* ADD NECESSARY ATTACH CONTROL ARGUMENTS TO FORTRAN I/O'S VFILE_ ATTACHMENT */

			if ^fortran_open_data.specified.attach_desc & using_vfile
			then do;

				fio_vfile_attach = "1"b;
						/* this is a fio created vfile_ attach desc */

/* Attach control arguments for vfile_ blocked files. */

				if fortran_open_data.specified.recl
				then do;

					call add_attach_option ("-no_end");
						/* Any record number is valid at any time. */

/* add "-blocked n" to force the file type */

					call add_attach_option ("-blocked");

					int_pic = fortran_open_data.max_rec_len;
						/* convert binary to char */
					call add_attach_option ((int_pic));
				     end;

/* Attach control arguments for vfile_ binary stream files. */

				if desired_file_type = binary_stream
				then do;
					call add_attach_option ("-no_trunc");
						/* prevents write from truncating */
					call add_attach_option ("-no_end");
						/* Any record number is valid at any time. */
				     end;

/* If opening for output and file is not binary stream, add "-extend". */

				else if fortran_open_data.out
				then do;
					call add_attach_option ("-extend");
					file_desc.rewind_on_open = "1"b;
				     end;

			     end;			/* code to add attach control arguments */


/* ATTACH THE FILE */

			call iox_$attach_iocb (iocb_ptr, attachment, my_code);

			if my_code ^= 0
			then do;
				call print_error (my_code);
				return;
			     end;

			file_desc.fortran_attached = "1"b;

		     end;				/* code to attach a file */


/* FILE TYPE IS UNKNOWN; CALCULATE IT */

		if uns_info.type = undefined
		then if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ "
		     then do;
			     using_vfile, erasable_file = "1"b;
						/* I/O module is vfile_ */

			     uns_info.info_version = vfs_version_1;
			     call iox_$control (iocb_ptr, "file_status", addr (info), my_code);
			     call process_vfile_status (/* file_type */);

/*	If file is attached by fortran I/O using an attach description created
			by fortran I/O, check that the correct attach description was generated.
			Fix it if it isn't. Currently this code is only executed if the target
			file is blocked or binary stream and the user did not specify the
			appropriate attribute in the open statement. */

			     if fio_vfile_attach
			     then if uns_info.type = blocked & desired_file_type ^= blocked
				then do;
					call iox_$detach_iocb (iocb_ptr, my_code);
					call add_attach_option ("-no_end");
					call iox_$attach_iocb (iocb_ptr, attachment, my_code);
					if my_code ^= 0
					then call print_error (my_code);
				     end;

				else if uns_info.type = binary_stream & desired_file_type ^= binary_stream
				then do;
					call iox_$detach_iocb (iocb_ptr, my_code);
					call add_attach_option ("-no_trunc");
					call add_attach_option ("-no_end");
					call iox_$attach_iocb (iocb_ptr, attachment, my_code);
					if my_code ^= 0
					then call print_error (my_code);
				     end;
			end;

/* non vfile_ cases */

		     else if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io
		     then uns_info.type = unstructured;

		     else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_mult_ "
		     then do;
			     uns_info.type = binary_stream;
			     uns_info.header_present = "0"b;
			end;
		     else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_nstd_ "
		     then file_desc.using_tape_nstd = "1"b;

/* IS DESIRED FILE TYPE COMPATIBLE WITH ACTUAL FILE TYPE? */

		if ^fortran_open_data.dfast_openfile	/* dfast ignores actual file type */
		then do;
			if file_type_matrix (desired_file_type, uns_info.type) = undefined
			then do;
				call print_error (fortran_io_error_$incompatible_opening, me,
				     "^/Existing file is a ^a file, but opening requires a ^a file.",
				     file_name (uns_info.type), file_name (desired_file_type));
				return;
			     end;
			else desired_file_type = file_type_matrix (desired_file_type, uns_info.type);
		     end;


/* FILE IS NOT OPEN; OPEN IT */

		if iocb_ptr -> iocb.open_descrip_ptr = null
						/* file is closed, open it */
		then do;


/* DETERMINE REQUEST TYPE */

/* formatted or unformatted */
			if fortran_open_data.specified.form
			then if fortran_open_data.formatted_records
			     then job_index = 1;
			     else job_index = 2;
			else if fio_ps.ansi_77 & ^fortran_open_data.direct_access
			then job_index = 1;
			else job_index = 2;

			if fortran_open_data.direct_access
						/* direct or sequential */
			then job_index = job_index + offset_for_direct_access;

/* INPUT / OUTPUT -- in and inout are considered input, except for the case of
		   inout and the file is empty or the file is not empty and fio created the attach
		   desc, then inout is treated as output.  This is done to protect vfiles from
		   accidental truncation.  If the attachment is not to a vfile and the mode is
		   output, we treat  this as output no matter what. */

			if fortran_open_data.out
			     & (file_is_empty | fio_vfile_attach | (^using_vfile & ^fortran_open_data.in))
			then job_index = job_index + offset_for_out_mode;


/* VFILE_ OPENING */

			if using_vfile
			then do;
				open_index = opening (job_index, desired_file_type);
				if open_index = 0
				then if job_index > offset_for_out_mode /* an output opening */
					&
					^fortran_open_data.specified.mode /* but OUT not explicitly requested */
					& opening (job_index - offset_for_out_mode, desired_file_type) ^= 0
						/* and IN is ok */
				     then do;
					     job_index = job_index - offset_for_out_mode;
						/* change to input only opening */
					     open_index = opening (job_index, desired_file_type);
					end;

				     else do;

/* attributes conflict with existing file */

					     call print_error (fortran_io_error_$incompatible_opening, me,
						"A ^a file.", file_name (desired_file_type));
					     return;
					end;

				call iox_$open (iocb_ptr, open_index, "0"b, my_code);

				if my_code ^= 0
				then do;

/* Opening can fail because of no write access. If so, try input only. */

					if my_code = error_table_$moderr
						/* insufficient access */
					then if job_index > offset_for_out_mode
						/* and attempted output opening */
					     then if ^fortran_open_data.specified.mode
						/* and no explicit mode */
						then if opening (job_index - offset_for_out_mode,
							desired_file_type) ^= 0
						/* and IN is ok */
						     then do;
							     job_index = job_index - offset_for_out_mode;
							     open_index =
								opening (job_index, desired_file_type);

							     call iox_$open (iocb_ptr, open_index, "0"b,
								my_code);
							end;

					if my_code ^= 0
					then call print_error (my_code);
				     end;

/* Some attach/open combinations position at the end of the file; 
        if rewind_on_open is true, position at the beginning of the file. */

				if file_desc.rewind_on_open
				then do;
					call iox_$position (iocb_ptr, -1, 0, my_code);
					if my_code ^= 0
					then call print_error (my_code);
				     end;

/* In ANSI 77 program units, if status = "append" in the open statement, 
        position the file pointer to the end of the file. */

				if fio_ps.ansi_77
				then do;
					if fortran_open_data.file_status = append_file
					then do;
						call iox_$position (iocb_ptr, +1, 0, my_code);
						if my_code ^= 0
						then call print_error (my_code);
					     end;
				     end;

			     end;			/* vfile opening */


/* NON VFILE_ BINARY FILE - tape_mult_ */

			else if desired_file_type = binary_stream
			then do;
				if fortran_open_data.out
				then open_index = 2;/* stream_output */
				else open_index = 1;/* stream_input */

				call iox_$open (iocb_ptr, open_index, "0"b, my_code);
				if my_code ^= 0
				then call print_error (my_code);
			     end;


/* UNKNOWN FILE TYPE, OPENING WILL DEFINE TYPE OF I/O */

			else do;
retry_non_vfile_opening:
				my_code = 1;
				do i = nstd (job_index).first to nstd (job_index).last while (my_code ^= 0);
				     open_index = nstd_opening (i);
				     call iox_$open (iocb_ptr, open_index, "0"b, my_code);

				     if my_code ^= 0
				     then if my_code = error_table_$moderr
						/* error is insufficient access */
					then if job_index > offset_for_out_mode
						/* and attempted output opening */
					     then if ^fortran_open_data.specified.mode
						/* and no explicit mode */
						then do;
						/* so try an input opening; only possible once */
							job_index = job_index - offset_for_out_mode;
							goto retry_non_vfile_opening;
						     end;
				end;
				if my_code ^= 0
				then call print_error (my_code, me, "Cannot open.");
			     end;			/* non vfile_ opening */

			file_desc.fortran_opened = "1"b;
		     end;				/* code to open the file */


/* FILE IS OPEN; DETERMINE TYPE OF I/O IF UNKNOWN */

		else do;

/* determine opening mode used */

			text_pt = iocb_ptr -> iocb.open_descrip_ptr;
						/* point to open descrip */
			i = length (before (text_pt -> b_var_str, " "));
						/* get open mode length */
			do open_index = 1 to hbound (iox_modes, 1)
			     while (substr (text_pt -> b_var_str, 1, i) ^= iox_modes (open_index));
			end;

/* If it is a non-standard open desc, see if we know about it. */

			if open_index > hbound (iox_modes, 1)
			then if substr (text_pt -> b_var_str, 1, 18) = "IOS compatability "
			     then open_index = 3;	/* stream_input_output */

			     else do;
				     call print_error (fortran_io_error_$fio_sys_error, me,
					"Unrecognized opening. ""^a""", text_pt -> b_var_str);
				     return;
				end;
		     end;				/* not opened by fortran */

		file_desc.open_code = open_index;
		file_desc.switch_ready = TRUE;
		if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_"
		then file_desc.eofs_are_records = TRUE; /*  An EOF is a physical record.  */


/* STORE ATTRIBUTES INTO FILE TABLE ENTRY */

/* type of I/O -- how to read, write, and position the file */

		if desired_file_type = binary_stream
		then do;
			file_desc.type_of_io = binary_file;

			if uns_info.type = binary_stream & uns_info.header_present & uns_info.header_id = 2
			then file_desc.double_word_file = "1"b;
		     end;

		else if desired_file_type = blocked
		then file_desc.type_of_io = blocked_file;

		else file_desc.type_of_io = open_mode (open_index).io_type;

/* Set allow_delete if and only if a) I/O switch is attached by FIO, b) I/O switch is opened by FIO, c) I/O switch is vfile_. */

		if erasable_file
		then if file_desc.fortran_attached & file_desc.fortran_opened
		     then file_desc.allow_delete = "1"b;

		call merge_attributes;		/* must precede assignment to file_desc.connected */

		file_desc.connected = "1"b;
	     end;					/* code to connect a file */


/* FILE IS CONNECTED; UPDATE ITS FILE TABLE ENTRY */

	else do;


/* If I/O switch is open, this is a normal open to a connected file. */

		if iocb_ptr -> iocb.open_descrip_ptr ^= null
		then do;
			using_vfile = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ ";

			call merge_attributes;
		     end;

/* I/O switch is closed. this must be an implicit opening */

		else if ^implicit_opening		/* i.e. - not caused by a data transfer */
		then call print_error (fortran_io_error_$fio_sys_error);

/* Open file. Use new opening mode only if allowed by user and necessary. */

		else if
		     ((string (open_mode (file_desc.open_code).direction) /* compare previous opening mode */
		     & string (fortran_open_data.direction)) ^= "0"b) /* to desired one; nonzero means compatible */
		     | ^file_desc.allow_reopen	/* unchangable */
		then do;				/* Old one is unchangable or compatible; use it */
			call iox_$open (iocb_ptr, (file_desc.open_code), "0"b, my_code);
			if my_code ^= 0
			then call print_error (my_code);
		     end;

/* Must reopen the file. */

		else if fortran_open_data.in
		then call reopen_for_input;
		else call reopen_for_output;

	     end;					/* code to process connected file */


/* Set previous as open in case I/O transmission fails. */

	file_desc.previous = open_opr;		/* save trouble of reopening later */
	return;					/* code for open statement */


/* CODE FOR CLOSE STATEMENT */

close_statement:
     entry;

/* If user gives status specifer, use it; otherwise the default is "keep".
   keep_status = 1 is "keep", 2 is "delete" */

	if fortran_open_data.specified.status
	then call convert_from_character (status_field, close_status_values, keep_status);
	else keep_status = 1;

	erasable_file = file_desc.allow_delete;		/* Copy values because close_fortran_file zeros them */
	if (keep_status = 2 & erasable_file) | file_desc.file_status = scratch_file
	then call save_attach_desc (attachment);

	call close_fortran_file;			/* close the file first */

/* If file is to be deleted, delete it now. */

	if file_desc.file_status = scratch_file
	then do;
		if fortran_open_data.specified.status & keep_status = 1
						/* user wants to keep */
		then call print_error (fortran_io_error_$close_attr_error, me,
			"Cannot keep scratch file associated with unit number ^d.", fio_ps.file_number);
		else do;
			call delete_file (attachment, fio_ps.file_number);
			file_desc.has_been_deleted = TRUE;
		     end;
	     end;
	else if keep_status = 2
	then do;
		if ^erasable_file			/* FIO does not have access to delete */
		then call print_error (fortran_io_error_$not_scratch_file, me,
			"Cannot delete file associated with unit number ^d.", fio_ps.file_number);
		else do;
			call delete_file (attachment, fio_ps.file_number);
			file_desc.has_been_deleted = TRUE;
		     end;
	     end;
	return;

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

add_attach_option:
     proc (a_str);

	dcl     a_str		 char (256) varying;

	if attach_desc_len + length (a_str) + 1 > length (attachment)
	then do;
		call print_error (fortran_io_error_$fio_sys_error, me, "Generated attach description is too long.");
		return;
	     end;

	substr (attachment, attach_desc_len + 2, length (a_str)) = a_str;
	attach_desc_len = attach_desc_len + length (a_str) + 1;
     end add_attach_option;


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

process_vfile_status:
     procedure (/* file_type */);

	if my_code = 0
	then if uns_info.info_version ^= vfs_version_1
	     then do;
		     call print_error (fortran_io_error_$fio_sys_error, me, "Wrong vfs version.");
		     return;
		end;
	     else do;
		     if uns_info.end_pos = 0
		     then file_is_empty = "1"b;

		     if uns_info.type = unstructured
		     then do;
			     if uns_info.header_present
			     then uns_info.type = binary_stream;

			     else if iocb_ptr -> iocb.attach_descrip_ptr ^= null
			     then call check_attach_options;
						/* attach options change file type */

			     if uns_info.end_pos = 0 & uns_info.type = unstructured
						/* zero length segment */
			     then uns_info.type = nonexistent;
			end;
		end;				/* vfile files */

	else if my_code = error_table_$noentry		/* file does not exist, but may be attached */
	then do;
		uns_info.type = nonexistent;
		file_is_empty = "1"b;		/* File is obviously empty. */

		if iocb_ptr -> iocb.attach_descrip_ptr ^= null
		then call check_attach_options;	/* attach options specify file type */
	     end;

	else do;
		call print_error (my_code);		/* error from vfile status */
		return;
	     end;

/* END OF process_vfile_status CODE */


check_attach_options:
     proc;					/* converts attach options to file type */

	dcl     adp		 ptr;		/* attach description pointer */

	adp = iocb_ptr -> iocb.attach_descrip_ptr;

	if index (adp -> b_var_str, "-blocked") ^= 0
	then uns_info.type = blocked;

     end check_attach_options;
     end process_vfile_status;


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

merge_attributes:
     proc;

	dcl     (actual_mode, desired_mode)
				 bit (2) aligned;

	if fortran_open_data.dfast_openfile
	then if file_desc.connected | ^file_desc.fortran_attached | ^file_desc.fortran_opened
	     then do;
		     call print_error (fortran_io_error_$fio_sys_error, me, "Connected attached, or opened in dfast.")
			;
		     return;
		end;

/* THE FOLLOWING ARE ERRORS IF FILE IS ALREADY CONNECTED */

	if file_desc.connected
	then if fortran_open_data.specified.status
	     then call print_error (fortran_io_error_$already_connected, me, "File status.");

	     else if fortran_open_data.specified.io_switch
	     then call print_error (fortran_io_error_$already_connected, me, "I/O switch name.");

	     else if fortran_open_data.specified.form
	     then call print_error (fortran_io_error_$already_connected, me, "Format attribute (form).");

	     else if fortran_open_data.specified.binary
	     then call print_error (fortran_io_error_$already_connected, me, "Binary stream attribute.");


/* ERRORS IF CONNECTED OR NOT ATTACHED BY FORTRAN */

	if file_desc.connected | ^file_desc.fortran_attached
	then do;

		if fortran_open_data.specified.attach_desc
		then do;
			call print_error (fortran_io_error_$already_opened, me, "Attach description.");
			return;
		     end;

		if fortran_open_data.specified.filename
		then do;
			call print_error (fortran_io_error_$already_opened, me, "Filename.");
			return;
		     end;
	     end;


/*			MODE - in, out, inout.

		Set only if explicitly specified or if file is being connected.
		"file_desc.allow_reopen" is set at the same time and allows reopening
		the file if the file opening does not support a specific data transfer.
		This attribute is set if and only if the following conditions are met:
		     1) FIOS opens the I/O module during connection;
		     2) the most recent mode specified for the file is "inout",
			or the file was connected implicitly as a result of a read or write,
			or a mode has never been specified for this file.
 */


	if ^file_desc.connected | fortran_open_data.specified.mode
	then do;
		actual_mode = string (open_mode (file_desc.open_code).direction);
						/* what file opening supports */
		desired_mode = string (fortran_open_data.direction);
						/* what user wants */

		file_desc.allow_reopen = ((desired_mode = "11"b) | implicit_opening) & file_desc.fortran_opened;

		if file_desc.allow_reopen		/* no need to fix now, can do it any time */
		then string (file_desc.direction) = actual_mode;

		else if file_desc.fortran_opened	/* reopen if necessary for new mode */
		then do;

/* At this point it is known that "desired_mode" cannot be "11"b or "00"b.
		   Therefore, the following tests for any incompatibility between the
		   actual and desired opening */

			if (actual_mode & desired_mode) = "0"b
						/* nothing in common, so reopen */
			then if fortran_open_data.direction.in
			     then call reopen_for_input;
			     else call reopen_for_output;

			string (file_desc.direction) = desired_mode;
						/* limit mode to that requested by user */
		     end;

/* Cannot reopen at all; actual and desired modes must be compatible */

		else do;

/* test for incompatible (=0), or usemore than there is */

			if ((actual_mode & desired_mode) = "0"b)
			     | (((actual_mode & desired_mode) ^= desired_mode) & fortran_open_data.specified.mode)
			then if ^fortran_open_data.direction.in
						/* tell him what he can't have */
			     then call print_error (fortran_io_error_$wrong_mode, me,
				     "Requested mode is ""input"".");
			     else call print_error (fortran_io_error_$wrong_mode, me,
				     "Requested mode is ""output"".");

			if implicit_opening | ^fortran_open_data.specified.mode
			then string (file_desc.direction) = actual_mode;
			else string (file_desc.direction) = desired_mode;
		     end;
	     end;					/* code to set mode */

	open_index = file_desc.open_code;		/* copy for use later on */


/*  SET FORM - formatted or unformatted.  Note that in '66 mode the default  */
/*  is always unformatted, while in '77 mode the default is formatted unless */
/*  the access is direct.                                                    */

	if fortran_open_data.specified.form
	then file_desc.formatted_records = fortran_open_data.formatted_records;
	else if ^file_desc.connected
	then if fio_ps.ansi_77
	     then if fortran_open_data.specified.access
		then file_desc.formatted_records = ^fortran_open_data.direct_access;
		else file_desc.formatted_records = TRUE;
	     else file_desc.formatted_records = FALSE;


/* SET ACCESS - allow/prohibit positioning, seq access, direct access */

	if ^file_desc.connected | fortran_open_data.specified.access
	then if fortran_open_data.direct_access
	     then do;
		     file_desc.allow.direct_access = "1"b;
		     file_desc.allow.positioning, file_desc.allow.seq_access =
			file_desc.type_of_io = blocked_file | file_desc.type_of_io = binary_file;
						/* These file types allow both sequential and direct access. */
		end;

	     else do;
		     file_desc.allow.positioning = "1"b;
		     file_desc.allow.direct_access = "0"b;
		     file_desc.allow.seq_access = "1"b;
		end;



/* CHECK FILE TYPE AND FORM */

	if file_desc.formatted_records
	then if file_desc.type_of_io = binary_file
	     then call print_error (fortran_io_error_$incompatible_opening, me, "Formatted opening for a binary file.");
	     else ;
	else if file_desc.type_of_io = stream_file
	then call print_error (fortran_io_error_$incompatible_opening, me, "Unformatted opening for a stream file.");


/* SET CARRIAGE - whether or not carriage control can be applied to the file */

	file_desc.carriage_controllable =
	     ^file_desc.allow.direct_access /* seq access only */ & file_desc.formatted_records /* formatted  file */
	     & file_desc.type_of_io = stream_file;	/* terminal or unstructured */

/* SET maximum record length and using_vfile */

	if fortran_open_data.specified.recl & using_vfile
	then call set_max_recl (fortran_open_data.max_rec_len);

	file_desc.using_vfile = using_vfile;

/* SET and CHECK blank attribute and file_status */

	file_desc.blank_null = fortran_open_data.blank_null;
	if fortran_open_data.specified.blank & ^fortran_open_data.formatted_records
	then call print_error (fortran_io_error_$incompatible_opening, me, "Blank specified for an unformatted file.");

	file_desc.file_status = fortran_open_data.file_status;
	if fortran_open_data.file_status = scratch_file & fortran_open_data.specified.attach_desc
	then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and status = ""scratch"".");

/* SET bit attributes */

	if fortran_open_data.specified.prompt
	then file_desc.prompt = fortran_open_data.prompt;

	if fortran_open_data.specified.carriage
	then file_desc.printer_file = fortran_open_data.carriage;

	if fortran_open_data.specified.defer
	then file_desc.defer_newline = fortran_open_data.defer;

     end merge_attributes;


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

convert_from_character:
     proc (fld_no, valid_values, which_one);

	declare valid_values	 (*) char (12) varying;
	dcl     (fld_no, i, num_valid_values, which_one)
				 fixed bin;
	declare error_string	 char (64) varying;
	declare given		 char (12) varying;

	call get_open_field (fld_no, off, len);

	given = translate (substr (fortran_open_data.char_str, off + 1, len), lower_letters, capital_letters);

	num_valid_values = hbound (valid_values, 1);

/*  scan till a match in the list of valid values */

	do i = 1 to num_valid_values;
	     if given = valid_values (i)
	     then do;
		     which_one = i;
		     return;
		end;
	end;

/* user hasn't given a valid value, tell him which one are valid */

	error_string = "";
	do i = 1 to num_valid_values - 2;
	     error_string = error_string || valid_values (i) || COMMA;
	end;
	error_string =
	     error_string || SP || valid_values (num_valid_values - 1) || " and " || valid_values (num_valid_values);

	call print_error (field_error (fld_no), me, "Unrecognized value for field. ""^a"".
^3xValues allowed are: ^a ", substr (fortran_open_data.char_str, off + 1, len), error_string);
     end convert_from_character;


     end open_statement;

inquire_statement:
     procedure;

/* This implements the ansi77 INQUIRE statement. It first distinquishes between the two kinds of such statements,
   by_file or by_unit.  It then checks  each of the specified fields to determine which information is required and 
   proceeds to capture  that info and store it in the location specified
   in the remained of the structure fort_inquire_data.  Full details in the 1978 version of the standard.
*/

	declare (by_file, in_range, file_connected, file_exists, need_name)
				 bit (1) aligned;
	declare unit_number		 fixed binary (18);
	declare return_string	 character (168) varying;
	declare dir_name		 char (168);
	declare ent_name		 char (32);
	declare based_bit_1		 bit (1) aligned based;

	by_file = fortran_inquire_data.specified.filename;

	if by_file
	then do;
		need_name = FALSE;

/* AT THIS POINT WE DEPEND THAT get_associated_unit WILL SET iocb_ptr */

		call get_associated_unit (ltrim (fortran_inquire_data.filename), unit_number, dir_name, ent_name,
		     code);
		if code = 0
		then do;
			file_connected = TRUE;
			file_exists = TRUE;
			fio_ps.file_number = unit_number;
						/* if needed for error message */
			fcb_ptr = addr (fortran_buffer_.table (unit_number));
		     end;
		else if code = error_table_$no_file
		then do;
			file_connected = FALSE;
			file_exists = FALSE;
		     end;
		else do;				/* file exists, but not connected */
			file_connected = FALSE;
			file_exists = TRUE;
		     end;
	     end /* by_file */;
	else do;					/* by unit */
		fio_ps.file_number, unit_number = fortran_inquire_data.unit;
		need_name = TRUE;
		if unit_number >= lbound (fortran_buffer_.table, 1) & unit_number <= hbound (fortran_buffer_.table, 1)
		then do;
			in_range = TRUE;
			fcb_ptr = addr (fortran_buffer_.table (unit_number));
			iocb_ptr = file_desc.switch_p;
			file_connected = fortran_buffer_.table (unit_number).connected;
		     end /* unit in range */;

		else do;
			file_connected = FALSE;
			in_range = FALSE;
		     end /* file number out of range */;
	     end;

/* The exist and opened fields are always defined */

	if fortran_inquire_data.specified.exist
	then do;
		if by_file
		then fortran_inquire_data.exist -> based_bit_1 = file_exists;
		else fortran_inquire_data.exist -> based_bit_1 = in_range;
	     end /* EXIST */;

	if fortran_inquire_data.specified.opened
	then fortran_inquire_data.opened -> based_bit_1 = file_connected;

/* If by unit and not connected, then no other fields are defined.
   If by file, then if not connected, the fields NAMED, NAME, SEQUENTIAL, DIRECT, FORMATTED and UNFORMATTED
   refer to the file, if it exists. NUMBER is defined iff OPENED is true.
   The remaining fields (ACCESS, FORM, RECl, NEXTREC, and BLANK) are only defined for connected files/units 
*/

	if (by_file & ^file_exists) | (^by_file & ^file_connected)
	then return;

/* the file is named if it is connected, uses vfile_ and not a scratch file, 
   or if not connected, and this is by_file 
   this file must exists and have a name of some sort.
*/

	if fortran_inquire_data.specified.named
	then do;
		if ^file_connected
		then fortran_inquire_data.named -> based_bit_1 = TRUE;
		else if file_desc.using_vfile
		then fortran_inquire_data.named -> based_bit_1 = (file_desc.file_status ^= scratch_file);
		else fortran_inquire_data.named -> based_bit_1 = FALSE;
	     end /* NAMED */;

	if fortran_inquire_data.specified.name
	then do;
		if (file_connected & file_desc.using_vfile & file_desc.file_status ^= scratch_file) | ^file_connected
		then do;
			if need_name
			then call get_name_of_unit;
			return_string = rtrim (dir_name) || ">" || rtrim (ent_name);
			call set_return_value (fortran_inquire_data.name.pointer, fortran_inquire_data.name.length,
			     return_string);
		     end /* not a scratch file */;
	     end /* NAME */;

	if fortran_inquire_data.specified.formatted
	then do;
		if file_connected
		then do;
			if file_desc.formatted_records
			then return_string = "YES";
			else return_string = "NO";
		     end;
		else return_string = "YES";		/* CAN be opened for formatted */
		call set_return_value (fortran_inquire_data.formatted.pointer, fortran_inquire_data.formatted.length,
		     return_string);
	     end /* FORMATTED */;

	if fortran_inquire_data.specified.unformatted
	then do;
		if file_connected
		then do;
			if file_desc.formatted_records
			then return_string = "NO";
			else return_string = "YES";
		     end;
		else return_string = "YES";		/* CAN be opened unformatted */
		call set_return_value (fortran_inquire_data.unformatted.pointer,
		     fortran_inquire_data.unformatted.length, return_string);
	     end /* UNFORMATTED */;

	if fortran_inquire_data.specified.sequential
	then do;
		if file_connected
		then do;
			if file_desc.allow.seq_access
			then return_string = "YES";
			else return_string = "NO";
		     end;
		else return_string = "YES";		/* all CAN be opened sequentially */
		call set_return_value (fortran_inquire_data.sequential.pointer,
		     fortran_inquire_data.sequential.length, return_string);
	     end /* SEQUENTIAL */;

	if fortran_inquire_data.specified.direct
	then do;
		if file_connected
		then do;
			if file_desc.allow.direct_access
			then return_string = "YES";
			else return_string = "NO";
		     end;
		else do;				/* by_file & no connected */
			uns_info.info_version = 1;	/* required for call to vfile_status_ */
			call vfile_status_ (dir_name, ent_name, addr (info), code);
			if code ^= 0
			then return_string = "UNKNOWN";
			else if uns_info.type = blocked | uns_info.type = indexed
			then return_string = "YES";
			else return_string = "NO";
		     end /* not connected */;
		call set_return_value (fortran_inquire_data.direct.pointer, fortran_inquire_data.direct.length,
		     return_string);
	     end /* DIRECT */;


/* The following attributes refer only to connected files/units */

	if ^file_connected
	then return;

	if fortran_inquire_data.specified.blank
	then do;
		if file_desc.blank_null
		then return_string = "NULL";
		else return_string = "ZERO";
		call set_return_value (fortran_inquire_data.blank.pointer, fortran_inquire_data.blank.length,
		     return_string);
	     end /* BLANK */;

	if fortran_inquire_data.specified.number
	then fortran_inquire_data.number -> words (1) = unit_number;


	if fortran_inquire_data.specified.access
	then do;
		if file_desc.allow.direct_access
		then return_string = "DIRECT";
		else return_string = "SEQUENTIAL";
		call set_return_value (fortran_inquire_data.access.pointer, fortran_inquire_data.access.length,
		     return_string);
	     end /* ACCESS */;

	if fortran_inquire_data.specified.form
	then do;
		if file_desc.formatted_records
		then return_string = "FORMATTED";
		else return_string = "UNFORMATTED";
		call set_return_value (fortran_inquire_data.form.pointer, fortran_inquire_data.form.length,
		     return_string);
	     end /* FORM */;

/* RECL is defined only if connected for direct access and this is a blocked file */

	if fortran_inquire_data.specified.recl
	then do;
		if file_desc.allow.direct_access
		then do;
			if file_desc.type_of_io = blocked_file | file_desc.type_of_io = record_file
			then do;
				if need_name
				then call get_name_of_unit;
				uns_info.info_version = 1;
						/* must be set before call to vfile_status_ */
				call vfile_status_ (dir_name, ent_name, addr (info), code);
				if code ^= 0
				then call print_error (code);
				else fortran_inquire_data.recl -> words (1) = blk_info.max_rec_len;
			     end /* blocked */;
			else call print_error (fortran_io_error_$not_blocked);
		     end /* direct access */;

	     end /* RECL */;

	if fortran_inquire_data.specified.nextrec
	then do;
		if file_desc.allow.direct_access
		then fortran_inquire_data.nextrec -> words (1) = file_desc.last_rec + 1;
	     end /* NEXTREC */;

	return;

get_name_of_unit:
     procedure;
	call save_attach_desc (attachment);
	call expand_pathname_ (attachment, dir_name, ent_name, code);
	if code ^= 0
	then call print_error (code, me, "Can't find filename in an inquire statement.");
	need_name = FALSE;
     end get_name_of_unit;

get_associated_unit:
     procedure (filename, unit_number, dir_name, ent_name, code);

/* Algorithm: get the unique id of the filename in question.  
   Then proceed through the array of files, stopping at the first with the same
   unique id.
   Note that the standard does not allow a file to be connected to more than one unit, so this is OKAY.
   The value of unit_number is undefined if there is no associated unit or no such file
   and a number in the range of permissable LUN's  otherwise (presently 1 - 99, with 0 reserved for the terminal).
   code = error_table_$no_file if the file doesn't exist and fortran_io_error_$not_open if it
   exists and is not open, i.e. connected to a unit.
*/
	declare filename		 char (*);	/* INPUT */
	declare dir_name		 char (*);	/* OUTPUT */
	declare ent_name		 char (*);	/* OUTPUT */
	declare unit_number		 fixed binary (18); /* OUTPUT */
	declare code		 fixed binary (35); /* OUTPUT */

	declare (file_uid, uid)	 bit (36) aligned;
	declare dname		 char (168);
	declare ename		 char (32);

	code = 0;
	call get_unique_id (filename, file_uid, dir_name, ent_name);
	if file_uid = no_uid
	then do;
		code = error_table_$no_file;
		return;
	     end;

	do i = 1 to hbound (fortran_buffer_.table, 1);
	     fcb_ptr = addr (fortran_buffer_.table (i));
	     iocb_ptr = file_desc.switch_p;
	     if file_desc.connected
	     then do;
		     if file_desc.switch_p ^= null
		     then do;
			     call save_attach_desc (attachment);
			     call get_unique_id (attachment, uid, dname, ename);
			     if uid = file_uid
			     then do;
				     unit_number = i;
				     return;
				end;
			end;
		end /* connected unit */;
	end /* do loop */;

/* if we've got to here, there is no match */

	code = fortran_io_error_$not_open;

     end get_associated_unit;

get_unique_id:
     procedure (filename, uid, dname, ename);

/* given a filename, return its unique id (uid), if it exists, otherwise no_uid */

%include branch_status;
	declare filename		 character (*);	/* INPUT */
	declare (dname, ename)	 character (*);	/* OUTPUT */
	declare uid		 bit (36) aligned;	/* OUTPUT */
	declare 1 my_status		 like branch_status;
	declare status_ptr		 pointer;
	declare chase_sw		 fixed bin (1) internal static options (constant) initial (1);

	call expand_pathname_ (filename, dname, ename, code);
	if code ^= 0
	then do;
		uid = no_uid;
		return;
	     end;

	status_ptr = addr (my_status);
	call hcs_$status_long (dname, ename, chase_sw, status_ptr, null, code);
	if code ^= 0
	then uid = no_uid;
	else uid = my_status.unique_id;

     end get_unique_id;

set_return_value:
     procedure (char_ptr, char_len, char_value);

	declare char_ptr		 unaligned pointer; /*  INPUT: addr of fortran char variable */
	declare char_len		 fixed binary (18); /* INPUT: length of fortran char variable */
	declare char_value		 char (168) varying;/* INPUT: what to put there */
	declare return_len		 fixed binary (18);
	declare based_chars		 char (char_len) based;

/* fill into the user's variable, the required value.  Truncate the correct character string if user has not provided
   enough room, and pad with blanks if the user has provided too much room.
*/
	return_len = min (char_len, length (char_value));
	if return_len < 1
	then return;

	substr (char_ptr -> based_chars, 1) = char_value;

     end set_return_value;

     end inquire_statement;

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

exists_file:
     proc (exists_file_code);

/* to determine if the file exists already if needed in OPEN statement. */

	declare exists_file_code	 fixed binary;
	declare my_code		 fixed binary (35);
	declare file_type		 fixed binary (2);
	declare bit_count		 fixed binary (24);
	declare pathname		 character (168);
	declare (off, len)		 fixed binary;

	call get_open_field (filename_field, off, len);

	exists_file_code = 0;

	if len > length (pathname)
	then exists_file_code = 1;

	else if len < 1
	then exists_file_code = 2;

	else do;
		pathname = substr (fortran_open_data.char_str, off + 1, len);
		call expand_pathname_ (pathname, dirname, entryname, my_code);
		if my_code ^= 0
		then exists_file_code = 3;

/* chase links on call to status (3rd arg = 1) */
		else do;
			call hcs_$status_minf (dirname, ltrim (entryname), 1, file_type, bit_count, my_code);
			if my_code ^= 0
			then exists_file_code = 3;
		     end;
	     end;

	return;
     end exists_file;

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

get_open_field:
     proc (field_num, str_off, str_len);

	dcl     field_num		 fixed bin;
	dcl     str_off		 fixed bin;
	dcl     str_len		 fixed bin;

	dcl     1 field		 (0:13) aligned based (addr (fortran_open_data)),
		2 off		 fixed bin (17) unaligned,
		2 len		 fixed bin (17) unaligned;

	str_off = field (field_num).off;

	str_len = length (rtrim (substr (fortran_open_data.char_str, str_off + 1, field (field_num).len)));

     end get_open_field;

/* THIS PROCEDURE IS USED TO SNAP THE LINK FOR THE APPROPRIATE FIELD MESSAGE */

field_error:
     proc (field_number) returns (fixed bin (35));

	dcl     field_number	 fixed bin;

	goto get_error_message (field_number);

get_error_message (1):
	return (fortran_io_error_$status_field_error);
get_error_message (2):
	return (fortran_io_error_$io_switch_field_error);
get_error_message (3):
	return (fortran_io_error_$attach_desc_field_error);
get_error_message (4):
	return (fortran_io_error_$filename_field_error);
get_error_message (5):
	return (fortran_io_error_$mode_field_error);
get_error_message (6):
	return (fortran_io_error_$access_field_error);
get_error_message (7):
	return (fortran_io_error_$form_field_error);
get_error_message (13):
	return (fortran_io_error_$blank_field_error);
     end field_error;

reopen_for_input:
     proc;

	dcl     (new_opening, original_opening)
				 fixed bin;
	dcl     (code, tcode)	 fixed bin (35);

	original_opening = file_desc.open_code;		/* save in case cannot reopen */

	call iox_$close (iocb_ptr, tcode);		/* error is irrelevant */

	tcode = 1;				/* to get into the loop */
	new_opening = open_mode (original_opening).for_input;

	do while (new_opening ^= 0 & tcode ^= 0);
	     call iox_$open (iocb_ptr, new_opening, "0"b, tcode);
	     if tcode ^= 0
	     then new_opening = open_mode (new_opening).for_input;
	end;

	if tcode ^= 0
	then do;
		call iox_$open (iocb_ptr, original_opening, "0"b, tcode);
		call print_error (fortran_io_error_$cannot_reopen, me, "Cannot open for input.");
		return;
	     end;

	file_desc.open_code = new_opening;
	string (file_desc.direction) = string (open_mode (new_opening).direction);
	return;


reopen_for_output:
     entry;

	original_opening = file_desc.open_code;		/* save in case cannot reopen */
	code = 0;					/* For error processing. */

	call iox_$close (iocb_ptr, tcode);		/* error is irrelevant */

	tcode = 1;				/* to get into the loop */
	new_opening = open_mode (original_opening).for_output;

	do while (new_opening ^= 0 & tcode ^= 0);
	     if ^(new_opening = Sequential_input_output & file_desc.type_of_io = blocked_file)
	     then call iox_$open (iocb_ptr, new_opening, "0"b, tcode);
	     if tcode ^= 0
	     then do;
		     if tcode = error_table_$moderr
		     then code = tcode;		/* Tells why reopen failed. */
		     new_opening = open_mode (new_opening).for_output;
		end;
	end;

	if tcode ^= 0
	then do;
		call iox_$open (iocb_ptr, original_opening, "0"b, tcode);
		if code = 0
		then code = fortran_io_error_$cannot_reopen;
						/* If no interesting msg, use canned one. */
		call print_error (code, me, "Cannot open for output.");
		return;
	     end;

	if file_desc.rewind_on_open
	then do;
		call iox_$position (iocb_ptr, -1, 0, my_code);
		if my_code ^= 0
		then call print_error (my_code);
	     end;

	file_desc.open_code = new_opening;
	string (file_desc.direction) = string (open_mode (new_opening).direction);
     end reopen_for_input;


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

close_fortran_file:
     proc;					/* caller must set "fcb_ptr" & "iocb_ptr" */

	if iocb_ptr ^= null
	then do;

		if iocb_ptr -> iocb.open_descrip_ptr ^= null
		then do;

/* If file is actually connected, flush its output buffer. */

			if file_desc.connected
			then call finish_line;

/* Close the I/O switch if fortran_io_ opened it. */

			if file_desc.fortran_opened
			then call iox_$close (iocb_ptr, my_code);
			else if file_desc.connected	/* rewind only if actually connected */
			then call iox_$position (iocb_ptr, -1, 0, my_code);
		     end;

		if file_desc.fortran_attached
		then call iox_$detach_iocb (iocb_ptr, my_code);
	     end;

/* Forget everything we ever knew about the file. */

	unspec (file_desc.per_connection) = "0"b;

     end close_fortran_file;


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

/*	Internal procedure to write the last newline character if necessary. */
finish_line:
     proc;

	my_code = 0;

	if file_desc.newline_needed
	then do;
		call iox_$put_chars (iocb_ptr, addr (NL), 1, my_code);
		file_desc.newline_needed = "0"b;
	     end;
     end finish_line;


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

close_for_stop:
     proc;					/* if there are files open, this procedure closes them. */

	dcl     buf_p		 ptr;
	dcl     ix		 fixed bin;

	if ^fast_related_data_$fortran_io_initiated	/* not initiated, therefore not open */
	then return;

	buf_p = fast_related_data_$fortran_buffer_p;
	if buf_p = null
	then return;				/* no segment, therefore not open */

	if buf_p -> fortran_buffer_.all_files_closed
	then return;				/* nothing is open */

/* Must always check in case fortran_buffer_.all_files_closed is wrong. */

	do ix = 1 to 99;

	     if buf_p -> fortran_buffer_.table (ix).fortran_opened
		| buf_p -> fortran_buffer_.table (ix).fortran_attached | buf_p -> fortran_buffer_.table (ix).connected
	     then do;
		     call close_all_files ("0"b);

		     buf_p -> fortran_buffer_.terminal_needs_newline = "0"b;
						/* true regardless of user answer */
		     return;
		end;
	end;

     end close_for_stop;


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

/* This procedure closes all open FORTRAN files. */

close_all_files:
     proc (by_stop_statement);

	dcl     by_stop_statement	 bit (1) aligned;	/* ="1"b if this proc should output newline chars */

	dcl     frn		 fixed bin,
	        fcode		 fixed bin (35);
	dcl     p			 ptr;
	declare killing_file	 bit (1) aligned;
	declare attach_description	 char (256);

/* This procedure must be coded very carefully as it is called as a finish handler to close all files. */

	if ^fast_related_data_$fortran_io_initiated
	then return;				/* never been used */

	p = fast_related_data_$fortran_buffer_p;	/* get buf ptr */
	if p = null
	then return;				/* never allocated */

/* output newline to terminal if needed */

	if p -> fortran_buffer_.terminal_needs_newline
	then do;
		if by_stop_statement
		then call iox_$put_chars (iox_$user_io, addr (NL), 1, fcode);
		p -> fortran_buffer_.terminal_needs_newline = "0"b;
	     end;

/* output newline to file0 if not the terminal */

	if p -> fortran_buffer_.table (0).newline_needed
	then if iox_$user_output -> iocb.actual_iocb_ptr ^= iox_$user_io
	     then call iox_$put_chars (iox_$user_output, addr (NL), 1, fcode);

	p -> fortran_buffer_.table (0).newline_needed = "0"b;

/* Check entire file table for connected files (and partially connected files) and disconnect them. */

	do frn = 1 to 99;

	     iocb_ptr = p -> fortran_buffer_.table (frn).switch_p;
	     if iocb_ptr ^= null
	     then do;
		     killing_file =
			p -> fortran_buffer_.table (frn).file_status = scratch_file
			& ^(p -> fortran_buffer_.table (frn).has_been_deleted);
		     if killing_file
		     then call save_attach_desc (attach_description);
		     if iocb_ptr -> iocb.open_descrip_ptr ^= null
		     then do;

/* Flush the file's output buffer only if the file is actually connected,
			needs a newline char, and isn't the terminal. */

			     if p -> fortran_buffer_.table (frn).connected
			     then if p -> fortran_buffer_.table (frn).newline_needed
				then if iocb_ptr -> iocb.actual_iocb_ptr ^= iox_$user_io
				     then call iox_$put_chars (iocb_ptr, addr (NL), 1, fcode);

/* Close (if opened by fortran_io_) or rewind (if actually connected) */

			     if p -> fortran_buffer_.table (frn).fortran_opened
			     then call iox_$close (iocb_ptr, fcode);
			     else if p -> fortran_buffer_.table (frn).connected
			     then call iox_$position (iocb_ptr, -1, 0, fcode);
			end;			/* processing for open I/O switch */

		     if p -> fortran_buffer_.table (frn).fortran_attached
		     then call iox_$detach_iocb (iocb_ptr, fcode);
		     if killing_file
		     then do;
			     call delete_file (attach_description, frn);
			     p -> fortran_buffer_.table (frn).has_been_deleted = TRUE;
			end;
		end;				/* I/O switch exists */
	     unspec (p -> fortran_buffer_.table (frn).per_connection) = "0"b;
	end;					/* loop to close all files */

	p -> fortran_buffer_.all_files_closed = "1"b;
     end close_all_files;

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

delete_file:
     procedure (saved_attach_desc, file_number);

/* deletes a file, either a scratch_file or if so indicated by the CLOSE statement  
    user MUST set iocb_ptr */

	declare saved_attach_desc	 char (*);	/* the pathname, saved from the attach desc */
	declare file_number		 fixed binary;	/* LUN associated with file */

	call expand_pathname_ (substr (saved_attach_desc, 1, attach_desc_len), dirname, entryname, my_code);
	if my_code ^= 0
	then do;
		call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number);
		return;
	     end;

	call delete_$path (dirname, entryname, "010111"b, me, my_code);
	if my_code ^= 0
	then do;
		call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number);
		return;
	     end;
     end delete_file;

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

save_attach_desc:
     procedure (attach_desc);
	declare attach_desc		 char (*);
	attach_desc_len = index (substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8), " ") - 1;
	if attach_desc_len < 0			/* i.e., no blank follows pathname */
	then attach_desc_len = length (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str) - 7;
	attach_desc = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8, attach_desc_len);
     end save_attach_desc;

error_handlers:
     procedure;

	call print_error (fortran_io_error_$fio_sys_error, me, "Illegal entry point.");

too_much_input:
     entry;
	call print_error (fortran_io_error_$short_record);

too_much_output:
     entry;
	call print_error (fortran_io_error_$long_record, me, "^d", buffer_max_len);

internal_file_overflow:
     entry;
	call print_error (fortran_io_error_$internal_file_oflow);

conversion_error:
     entry;
	buffer_index = begin_index;			/* Point to beginning of constant for error. */
	call print_error (fortran_io_error_$conversion_error);

bad_char:
     entry;
	call print_error (fortran_io_error_$bad_char, me, """^a""", substr (rest_of_field, 1, 1));

syntax_error:
     entry;
	call print_error (fortran_io_error_$syntax_error);

     end error_handlers;

/*	Procedure to abort the FORTRAN I/O system. */
print_error:
     proc options (variable);				/* First argument must be valid error code. rest are optional */

	dcl     comp_name		 char (32) aligned,
	        dir_name		 char (168),
	        ent_name		 char (256),
	        seg_name		 char (32);

	dcl     std		 bit (1) aligned,
	        op_name		 char (32) varying,
	        (start, num, line_no, offset)
				 fixed bin (18),
	        cur_op		 fixed bin,
	        bit_cnt		 fixed bin (24),
	        (error_code, tcode)	 fixed bin (35);

	dcl     (ap, err_point, seg_base, sym_tab, p)
				 ptr;

	dcl     length		 builtin;

	declare component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)),
	        cu_$arg_count	 entry (fixed bin (18)),
	        cu_$arg_list_ptr	 entry (ptr),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin, fixed bin (35)),
	        cu_$gen_call	 entry (entry, ptr),
	        get_entry_name_	 entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)),
	        hcs_$fs_get_path_name	 entry (ptr, char (*), fixed bin (18), char (*), fixed bin (35)),
	        hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
	        object_info_$brief	 entry (ptr, fixed bin (24), ptr, fixed bin (35)),
	        stack_frame_exit_	 entry (ptr, ptr, ptr, bit (1), ptr, char (32), ptr),
	        stu_$get_line_no	 entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18))
				 returns (fixed bin (18)),
	        stu_$get_runtime_line_no
				 entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18))
				 returns (fixed bin (18));

%include component_info;
%include object_info;
%include symbol_header;

	dcl     1 oi		 aligned like object_info;


/* GET ERROR CODE */

	call cu_$arg_ptr (1, p, 0, error_code);		/* third arg is char len which is meaningless */

	if error_code = 0
	then error_code = p -> words (1);		/* if call fails, FIOS error, so print why it failed */

/* Save info about last error. */

	if my_code ^= 0
	then actual_error = my_code;
	else actual_error = error_code;

	ps_at_error = PS_ptr;
	string (PS.job_bits) = string (fio_ps.job_bits);
	PS.element_p = fio_ps.element_p;
	PS.file_number = fio_ps.file_number;

/*  IOSTAT FIELD - return the error code to the user instead of printing an error */

	if fio_ps.iostat_var
	then do;
		PS.iostat_p -> words (1) = error_code;	/* copy into user's variable */

		if ^fio_ps.error_label		/* If err= specified, it is handled below */
		then goto return_error_code;
	     end;

/* ERR FIELD - return to the user instead of printing an error */

	if fio_ps.error_label			/* Return to user if err= specified. */
	then call return_to_user (PS.error_p, PS.stack_frame_p);

/* OPENFILE ERRORS - print only if the file is subsequently referenced */

	if fio_ps.control_type = bit (openfile_opr, 4)
	then if fast_related_data_$in_dfast
	     then if fio_ps.file_number >= 1 & fio_ps.file_number <= 99
		then do;
			num = fio_ps.file_number;

			fortran_buffer_.table (num).previous = 0;
						/* indicates that file is not open */
			fortran_buffer_.table (num).open_code = 1;
						/* how to decode the error message */
			unspec (fortran_buffer_.table (num).switch_p) = unspec (error_code);
						/*  a kludge but it works */
			goto return_error_code;	/* results in a return to the user */
		     end;


/* PRINT AN ERROR MESSAGE */


/* End last output line BEFORE printing error message. */

	if fortran_buffer_.terminal_needs_newline
	then do;
		call iox_$put_chars (iox_$user_io, addr (NL), 1, tcode);
		fortran_buffer_.terminal_needs_newline = "0"b;
	     end;

/* If caller provides extra info about the error, print caller's info first */

	call cu_$arg_count (num);

	if num > 1				/* Will always have one argument. */
	then do;
		call cu_$arg_list_ptr (ap);
		call cu_$gen_call (com_err_, ap);
		error_code = 0;
	     end;


/* PRINT LOCATION IN USER PROGRAM. */

/* get return address in user's program */

	sp = PS.stack_frame_p;
	call stack_frame_exit_ (sp, null, null, "0"b, err_point, seg_name, addr (work));
						/* Get return address. */
	seg_base = ptr (err_point, 0);		/* Base pointer. */
	num, offset = binary (rel (err_point), 18);

/* get entry point name */

	call get_entry_name_ (sp -> stack_frame.entry_ptr, ent_name, 0, (8)" ", tcode);
	if tcode ^= 0
	then ent_name = " ";
	comp_name = substr (ent_name, 1, 32);		/* In case not bound segment. */

/* get status of object segment to see if it has a symbol table */

	call component_info_$offset (seg_base, offset, addr (ci), tcode);
	if tcode = 0				/* This is a bound segment. */
	then do;
		sym_tab = ci.symb_start;
		std = ci.standard;
		offset = offset - binary (rel (ci.text_start), 18);
		comp_name = ci.name;
	     end;
	else do;					/* Not bound. */
		call hcs_$status_mins (seg_base, 0, bit_cnt, tcode);
						/* Get bit count. */
		if tcode ^= 0
		then go to no_line;			/* No access. */

		oi.version_number = object_info_version_2;
		call object_info_$brief (seg_base, bit_cnt, addr (oi), tcode);
		if tcode ^= 0
		then go to no_line;

		sym_tab = oi.symbp;
		std = oi.format.standard;
	     end;

/* if object segment has symbol table, get line number */

	start = -1;
	if std
	then line_no = stu_$get_runtime_line_no (sym_tab, num, start, 0);
	else if sym_tab -> symbol_header.root ^= "0"b
	then line_no = stu_$get_line_no (addrel (sym_tab, sym_tab -> symbol_header.root), num, start, 0);

	if start > 0
	then do;
		int_pic = line_no;
		substr (work, verify (work, SP) - 5, 4) = "Line";
	     end;
	else
no_line:
	     substr (work, 1, length (int_pic)) = SP;

/* get full pathname */

	call hcs_$fs_get_path_name (seg_base, dir_name, 0, seg_name, tcode);

/* PRINT THE ERROR MESSAGE */

	if fio_ps.mode = string_io | fio_ps.mode = internal_file
	then do;
		if fio_ps.mode = string_io
		then if fio_ps.read
		     then op_name = "Decode";
		     else op_name = "Encode";
		else if fio_ps.read
		then op_name = "Internal file read";
		else op_name = "Internal file write";

		if (ent_name = seg_name) & (comp_name = seg_name)
		then call com_err_ (error_code, me, "^a statement error by ^a>^a|^o^a", op_name, dir_name, seg_name,
			offset, int_pic);
		else call com_err_ (error_code, me, "^a statement error by ^a>^a$^a at ^a|^o^a", op_name, dir_name,
			seg_name, ent_name, comp_name, offset, int_pic);
	     end /* string_io */;

	else do;

/* Convert request to char str. */

		if fio_ps.control_type ^= "0"b
		then do;
			cur_op = binary (fio_ps.control_type, 3, 0);
			op_name = "";		/* No qualifiers for control operations. */
		     end;
		else do;

			if fio_ps.read
			then cur_op = read_opr;
			else cur_op = write_opr;

			op_name = rtrim (format_type (binary (fio_ps.format, 2)));

			if fio_ps.mode = direct_access
			then op_name = op_name || " direct access";
			else op_name = op_name || " sequential";
		     end;

/* Print message. */

		if (ent_name = seg_name) & (comp_name = seg_name)
		then call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a|^o^a", op_name,
			operation_name (cur_op), fio_ps.file_number,
						/* info about request */
			dir_name, seg_name, offset, int_pic);
						/* segment info */
		else call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a$^a (^a|^o)^a", op_name,
			operation_name (cur_op), fio_ps.file_number,
						/* info about request */
			dir_name, seg_name, ent_name, comp_name, offset, int_pic);
						/* segment info */

		if fio_ps.have_input & buffer_length > 0
		then do;
			call ioa_$ioa_switch (iox_$error_output,
			     "Error occurred at character ^d of this record:^/""^a""", buffer_index + 1, io_buf);
			call ioa_$ioa_switch (iox_$error_output, "^vxI", buffer_index + 1);
		     end;

		if ^fast_related_data_$in_fast_or_dfast
		then call close_for_stop;
	     end /* neither string_io nor internal_file */;


/* TERMINATE THE RUN */

/* SCP 6315 call another command level if the program was compiled 
      with -debug_io otherwise just die gracefully
*/
	if fio_ps.debug_io then call cu_$cl ("0"b);

	if fast_related_data_$in_fast_or_dfast
	then call fast_related_data_$terminate_run;
	else call stop_run;

	do while ("1"b);
	     signal illegal_return;
	end;

     end print_error;

/* Procedure for unformatted I/O. */
unformatted_io:
     proc;

/* get total size of element = element_size * element_count */

	call set_size_and_count (char_len, element_count, chars_per_item);
	char_len = chars_per_item * element_count;

/* Perform I/O. */

	if fio_ps.read
	then if file_desc.type_of_io ^= binary_file
	     then do;				/* Not binary file. Copy characters from buffer into variable. */

		     if buffer_index + char_len > buffer_length
		     then call too_much_input;

		     if ^fio_ps.element_desc.VLA
		     then substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, char_len);
		     else do;
			     chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1;
			     if char_len <= chars_left
			     then substr (fio_ps.element_p -> chars, 1, char_len) =
				     substr (rest_of_record, 1, char_len);
			     else do;		/*  Target crosses into next VLA component.  */
				     substr (fio_ps.element_p -> chars, 1, chars_left) =
					substr (rest_of_record, 1, chars_left);
				     substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1,
					char_len - chars_left) =
					substr (rest_of_record, chars_left + 1, char_len - chars_left);
				end;
			end;

		     buffer_index = buffer_index + char_len;
						/* Keep track of how many read */
		end;				/* code to read non binary file */

	     else do;				/* Binary file. Read data directly into the variable */

		     if file_desc.double_word_file & ^fio_ps.double
		     then call print_error (fortran_io_error_$dnumeric_file);

		     fio_ps.element_count = char_len;	/* store length of item */
		     call read_a_record;		/* read directly into the item */
		end;				/* code to read binary file */

	else do;					/* Write logic. It is the same for all file types */

		if file_desc.double_word_file & ^fio_ps.double
		then call print_error (fortran_io_error_$dnumeric_file);

		if buffer_length + char_len > buffer_max_len
		then call too_much_output;

		if ^fio_ps.element_desc.VLA
		then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len);
		else do;
			chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1;
			if char_len <= chars_left
			then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len);
			else do;			/*  Source crosses into next VLA component.  */
				substr (rest_of_output, 1, chars_left) =
				     substr (fio_ps.element_p -> chars, 1, chars_left);
				substr (rest_of_output, chars_left + 1, char_len - chars_left) =
				     substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1,
				     char_len - chars_left);
			     end;
		     end;

		buffer_length = buffer_length + char_len;
	     end;					/* write logic */

     end unformatted_io;

/* Formatted I/O. */
formatted_io:
     proc;



/*	Constants */

	dcl     fixed_decimal	 fixed bin init (18) internal static options (constant);
	dcl     (
	        READ_		 init (30),
	        WRITE_		 init (0)
	        )			 fixed bin int static options (constant);
	declare MINUS_SIGN		 char (1) int static options (constant) init ("-");
	declare PLUS_SIGN		 char (1) int static options (constant) init ("+");

/*	Automatic declarations. */

	dcl     op_offset		 fixed bin;

	dcl     1 field		 aligned,
		2 spec		 fixed bin,
		2 rep_factor	 fixed bin,
		2 width		 fixed bin,
		2 precision	 fixed bin,
		2 exponent	 fixed bin;

	dcl     1 FORMAT		 aligned,
		2 indx		 fixed bin,
		2 scale		 fixed bin,
		2 paren_level	 fixed bin,
		2 restart		 (5) fixed bin,
		2 rep_factor	 (5) fixed bin;

	declare blanks_as_null	 bit (1) aligned;
	declare leading_sign	 char (1);
	dcl     infinite_format	 bit (1) aligned;
	dcl     decimal_len		 fixed bin (35);
	dcl     decimal_type	 fixed bin;
	dcl     exponent		 fixed decimal (3);
	dcl     (exp, negate)	 fixed bin;
	dcl     add_zero		 bit (1) aligned;
	declare effective_digits	 fixed binary;
	declare digits_after_E	 fixed binary;
	declare x			 float binary;
	dcl     lied_about_sign	 bit (1);

/* WARNING: This structure is based on the internal representation of extended float decimal data */
	dcl     1 x_float		 aligned structure,
		2 char_pad	 char (11) unaligned,
		2 exp		 fixed bin (8) unaligned;

	dcl     x_flt		 float decimal (10) based (addr (x_float));
	dcl     scale		 fixed bin;
	dcl     element_v		 float bin (63);
	dcl     bin_int		 fixed bin (35);
	dcl     min_field_width	 fixed bin;

/*	Based variables. */
	dcl     (
	        float_bin		 float bin (27),
	        logical		 bit (1)
	        )			 aligned based (fio_ps.element_p),
	        in_fmt		 char (1024) aligned based (PS.user_format_p);
	dcl     dec_int_picture	 char (12) based (addr (dec_int));

/* constant */

	declare ten_to_the_power	 (-38:38) float bin (63) int static options (constant)
				 init (1e-38, 1e-37, 1e-36, 1e-35, 1e-34, 1e-33, 1e-32, 1e-31, 1e-30, 1e-29,
				 1e-28, 1e-27, 1e-26, 1e-25, 1e-24, 1e-23, 1e-22, 1e-21, 1e-20, 1e-19, 1e-18,
				 1e-17, 1e-16, 1e-15, 1e-14, 1e-13, 1e-12, 1e-11, 1e-10, 1e-09, 1e-08, 1e-07,
				 1e-06, 1e-05, 1e-04, 1e-03, 1e-02, 1e-01, 1e+00, 1e+01, 1e+02, 1e+03, 1e+04,
				 1e+05, 1e+06, 1e+07, 1e+08, 1e+09, 1e+10, 1e+11, 1e+12, 1e+13, 1e+14, 1e+15,
				 1e+16, 1e+17, 1e+18, 1e+19, 1e+20, 1e+21, 1e+22, 1e+23, 1e+24, 1e+25, 1e+26,
				 1e+27, 1e+28, 1e+29, 1e+30, 1e+31, 1e+32, 1e+33, 1e+34, 1e+35, 1e+36, 1e+37,
				 1e+38);

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

	call set_size_and_count (char_len, element_count, chars_per_item);

/* For complex data, we will treat the real and imaginary parts as separate elements. */

	if fio_ps.element_desc.complex
	then do;
		element_count = element_count * 2;
		char_len, chars_per_item = CPW;
	     end;

	goto format_routine (field.spec);

/* Unpack format as it is used in hopes of minimizing the cost of using it. */

get_next_format:					/* Come here to get next field if fmt is unpacked. */
	fmt_ptr = addr (format_p -> runtime_format.fmt (FORMAT.indx));
	FORMAT.indx = FORMAT.indx + 1;

	field.spec = fmt_ptr -> format.spec + op_offset;
	goto unpack_format (field.spec);


unpack_format (0):
	call unpack_two;
	goto i_format_common;
unpack_format (22):					/* output extended_i_format */
	call unpack_three;
i_format_common:
	infinite_format = "0"b;
format_routine (22):
format_routine (0):					/* output i-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;

/*  Save the binary integer to be printed in 'bin_int', then convert it to   */
/*  decimal in 'dec_int'.  Note that we refer to 'dec_int' through its alias */
/*  'dec_int_picture' because we know that the hardware representation is a  */
/*  character string consisting of a '+' or '-' followed by the ASCII form   */
/*  of the digits in the decimal value of the number.                        */
	bin_int = fio_ps.element_p -> words (1);
	dec_int = bin_int;

/*  Store the number of digits to be output in 'effective_digits'.  */
	if bin_int = 0
	then if field.spec = extended_i_format
	     then effective_digits = field.precision;
	     else effective_digits = 1;
	else do;
		effective_digits = length (dec_int_picture) - verify (dec_int_picture, "+-0") + 1;
		if field.spec = extended_i_format
		then if field.precision > effective_digits
		     then effective_digits = field.precision;
	     end;

/*  Calculate the minimum field width needed to display the number and check */
/*  that we actually have that much.                                         */
	min_field_width = effective_digits;
	if effective_digits > 0			/*  i.e. if a sign is allowed  */
	then if bin_int < 0 | must_produce_plus
	     then min_field_width = min_field_width + 1;
	if field.width - min_field_width < 0
	then goto print_stars;

/*  If we have more field than needed, store enough spaces at the start of   */
/*  the field to take up the slack.                                          */
	if field.width - min_field_width > 0
	then do;
		substr (rest_of_field, 1, field.width - min_field_width) = "";
		buffer_index = buffer_index + (field.width - min_field_width);
	     end;

/*  Store the sign if it's needed.  */
	if min_field_width > effective_digits
	then do;
		substr (rest_of_field, 1, 1) = substr (dec_int_picture, 1, 1);
		buffer_index = buffer_index + 1;
	     end;

/*  If more digits are required than we have in 'dec_int_picture', the extra */
/*  digits must all be zeroes since 'dec_int' is big enough to hold any      */
/*  'fixed bin (35)' value.                                                  */
	do while (effective_digits >= length (dec_int_picture));
	     substr (rest_of_field, 1, 1) = "0";
	     buffer_index = buffer_index + 1;
	     effective_digits = effective_digits - 1;
	end;

/*  Store as many digits from the right end of 'dec_int_picture' as are      */
/*  needed to fill the field.                                                */
	substr (rest_of_field, 1, effective_digits) =
	     substr (dec_int_picture, length (dec_int_picture) - effective_digits + 1, effective_digits);

	goto countdown_element;


unpack_format (1):
	call unpack_three;
	infinite_format = "0"b;

/* Assign_round_ is called to make a scaled fixed decimal according to the user's spec, if
the number wont fit, fixedoverflow is signalled.  If the relationship between the data
precision and the size of the field causes a hardware fault this results in zerodivide
being signalled. */

format_routine (1):					/* output f-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;

	if fio_ps.double
	then element_v = fio_ps.element_p -> based_dp;
	else element_v = fio_ps.element_p -> float_bin;

/*  Set 'negate' equal to the sign bit of the element, except in '77 mode    */
/*  when the element is between -0.5 and 0, in which case we pretend the     */
/*  element is positive so that if it underflows the field we will not get   */
/*  minus zero as the result.                                                */

	lied_about_sign = "0"b;
	if element_v >= 0
	then negate = 0;
	else if element_v > -0.5 & fio_ps.ansi_77
	then do;
		negate = 0;
		lied_about_sign = "1"b;
	     end;
	else negate = 1;
	i = 1;
	call start_floating;
	scale = field.precision + FORMAT.scale;
	prec = field.width - negate - 1;
	decimal_len = prec + 262144 * scale;
	decimal_type = fixed_decimal;
	call create_decimal;			/* Create fixed scaled decimal number. */

	if lied_about_sign				/* If this point is reached and the flag is true,
	                                                     then an underflow did not occur in the create_decimal routine.  */
	then do;					/* Drop the pretense that the element is positive. */
		negate = 1;
		i = 1;
		call start_floating;
		if ^must_produce_plus
		then do;
			substr (number.digit, 1, prec - 1) = substr (number.digit, 2, prec - 1);
						/* Remove leftmost digit so the number corresponds to the proper precision. */
			prec = prec - 1;		/* Precision is one less since the element is negative. */
			count = count - 1;
		     end;
	     end;
	if count >= prec - field.precision		/* First non-zero digit is to right of decimal point. */
	then if prec - field.precision = 0
	     then count = 0;			/* Print as .0... */
	     else count = (prec - field.precision) - 1;	/* Print as 0.0... */

	i = field.width - count;
	call minus_sign;

	i = prec - field.precision - count;
	if i > 0
	then do;
		substr (rest_of_record, 1, i) = substr (number.digit, count + 1, i);
		buffer_index = buffer_index + i;
	     end;

	substr (rest_of_record, 1, 1) = ".";

	if field.precision > 0
	then substr (rest_of_record, 2, field.precision) =
		substr (number.digit, prec - field.precision + 1, field.precision);
	goto countdown_element;


unpack_format (2):
unpack_format (4):
	call unpack_four;
	infinite_format = "0"b;
format_routine (2):					/* output e-format */
format_routine (4):					/* Output d-format */
						/* e- and d-format should not raise any conditions.  Conversion is done by assign_round_. */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;

e_fmt:
	if fio_ps.element_p -> float_bin >= 0
	then negate = 0;
	else negate = 1;
	if field.exponent = 0			/* exponent not explict */
	then do;
		digits_after_E = 2;			/* ansi standard p 13-11 */
		i = 5;				/* reserved places, leading "." trailing "E+xx" */
	     end;
	else do;
		digits_after_E = field.exponent;
		i = field.exponent + 3;		/* reserved for leading "." and exponent field */
	     end;
	call start_floating;

	if FORMAT.scale <= 0
	then do;
		prec = field.precision + FORMAT.scale;
		if prec <= 0
		then goto print_stars;
	     end;
	else do;
		prec = field.precision + 1;
		if prec < FORMAT.scale
		then goto print_stars;
		if ^add_zero
		then go to print_stars;
	     end;

	decimal_len = prec;
	decimal_type = ext_float_decimal;
	call create_decimal;

	exponent = number.exp + prec - FORMAT.scale;
	if count > 0
	then do;
		number.digit = substr (number.digit, count + 1) || substr (number.digit, 1, count);
		exponent = exponent - count;
	     end;
	if field.exponent = 0 & abs (exponent) > 99
	then digits_after_E = 3;

	if abs (exponent) >= ten_to_the_power (digits_after_E)
	then goto print_stars;			/* does exponent fit? */
	call minus_sign;

	if FORMAT.scale > 0
	then do;
		substr (rest_of_record, 1, FORMAT.scale) = substr (number.digit, 1, FORMAT.scale);
		count = FORMAT.scale;
		buffer_index = buffer_index + FORMAT.scale;
	     end;
	else do;
		count = 0;
		if add_zero
		then do;
			substr (rest_of_record, 1, 1) = "0";
			buffer_index = buffer_index + 1;
		     end;
	     end;

	substr (rest_of_record, 1, 1) = ".";
	buffer_index = buffer_index + 1;

	if FORMAT.scale < 0
	then do;
		substr (rest_of_field, 1, -FORMAT.scale) = copy ("0", -FORMAT.scale);
		buffer_index = buffer_index - FORMAT.scale;
	     end;

	if prec - count > 0
	then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count);
	buffer_index = buffer_index + prec - count;

/* include the E character if the exponent < 100 or the exponent length is specified */
	if abs (exponent) < 100 | field.exponent > 0
	then do;
		if field.spec = d_format
		then substr (rest_of_record, 1, 1) = "D";
		else substr (rest_of_record, 1, 1) = "E";
		buffer_index = buffer_index + 1;
	     end;

	if exponent < 0
	then substr (rest_of_record, 1, 1) = MINUS_SIGN;
	else substr (rest_of_record, 1, 1) = PLUS_SIGN;
	buffer_index = buffer_index + 1;

/* in binary floating point, largest exponent (even with scale factor) is 2 
   digits long so if exponent field is to be longer, we need to prefix zeros.
   Finally, put in the exponent as calculated at the end.  In hex floating
   point, an exponent could be larger then 99.
*/
	if abs (exponent) > 99
	then do;
		if digits_after_E > 3
		then do;
			substr (rest_of_record, 1, digits_after_E - 3) = copy ("0", digits_after_E - 3);
			buffer_index = buffer_index + digits_after_E - 3;
		     end;
		substr (rest_of_record, 1, 3) = substr (addr (exponent) -> chars, 2, 3);
	     end;
	else do;
		if digits_after_E > 2
		then do;
			substr (rest_of_record, 1, digits_after_E - 2) = copy ("0", digits_after_E - 2);
			buffer_index = buffer_index + digits_after_E - 2;
		     end;
		effective_digits = min (digits_after_E, 2);
		substr (io_buf, last - effective_digits + 1, effective_digits) =
		     substr (addr (exponent) -> chars, 5 - effective_digits, effective_digits);
	     end;
	goto countdown_element;


unpack_format (3):
	call unpack_two;
	infinite_format = "0"b;
format_routine (3):					/* output l-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;
	if field.width - 1 > 0
	then substr (rest_of_record, 1, field.width - 1) = " ";

	if logical
	then substr (io_buf, last, 1) = "T";
	else substr (io_buf, last, 1) = "F";
	goto countdown_element;


unpack_format (5):
	call unpack_two;
	infinite_format = "0"b;
format_routine (5):					/* output o-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;

	count = chars_per_item * 3;
	if field.width > count
	then do;
		substr (rest_of_record, 1, field.width - count) = " ";
		buffer_index = buffer_index + (field.width - count);
		i = 0;
	     end;
	else i = -3 * (field.width - count);

	do i = i to count * 3 - 1 by 3;
	     substr (rest_of_record, 1, 1) =
		substr ("01234567", binary (substr (fio_ps.element_p -> based_bits, i + 1, 3), 3) + 1, 1);
	     buffer_index = buffer_index + 1;
	end;
	goto countdown_element;


unpack_format (6):
	call unpack_four;
	infinite_format = "0"b;
format_routine (6):					/* output g-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;

	prec = field.precision;
	if prec = 0 | prec > max_float | prec > hbound (ten_to_the_power, 1)
	then go to e_fmt;
	else do;
		if fio_ps.job_bits.hfp
		then do;
			call assign_round_ (addr (x_float), ext_float_decimal, 10, fio_ps.element_p,
			     binary_type (3), binary_prec (3));
			if x_float.exp > (hbound (ten_to_the_power, 1) - 10)
			     | x_float.exp < (-hbound (ten_to_the_power, 1) - 10)
			then goto e_fmt;
			x_float.exp = fixed (x_float.exp, 7);
			x = abs (x_flt);
		     end;
		else x = abs (fio_ps.element_p -> float_bin);
		if x < 1.0e-1 | x >= ten_to_the_power (prec)
		then goto e_fmt;
	     end;

	if fio_ps.element_p -> float_bin >= 0
	then negate = 0;
	else negate = 1;
	if field.exponent = 0
	then do;					/* not given, use defaults */
		effective_digits = 4;
		i = 5;
		digits_after_E = 2;
	     end;
	else do;					/* set up user defined widths */
		effective_digits = field.exponent + 2;
		i = field.exponent + 1;
		digits_after_E = field.exponent;
	     end;
	call start_floating;

	decimal_len = prec;
	decimal_type = ext_float_decimal;
	call create_decimal;

	exp = prec - count + number.exp;
	if exp < 0 | exp > field.precision
	then go to e_fmt;

	i = negate + 1 + field.precision - count + effective_digits;
	call minus_sign;

	if exp > 0
	then do;
		substr (rest_of_record, 1, exp) = substr (number.digit, count + 1, exp);
		buffer_index = buffer_index + exp;
		count = count + exp;
	     end;

	substr (rest_of_record, 1, 1) = ".";
	buffer_index = buffer_index + 1;

	if prec - count > 0
	then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count);

	substr (io_buf, last - effective_digits + 1, effective_digits) = copy (SP, effective_digits);
	goto countdown_element;


unpack_format (30):
unpack_format (52):
	call unpack_two;
	infinite_format = "0"b;
format_routine (30):				/* input i-format */
format_routine (52):				/* input extended i format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call read_buffer;
	begin_index = buffer_index;			/* For error message. */
	i = verify (substr (rest_of_field, 1, field.width), " ") - 1;
	if i < 0
	then do;
fixed_zero:
		fio_ps.element_p -> words (1) = 0;
		goto countdown_element;
	     end;
	buffer_index = buffer_index + i;

	dec_int = 0;
	if substr (rest_of_field, 1, 1) = "-"
	then do;
		substr (work, 1, 4) = "-000";
		buffer_index = buffer_index + 1;
		if buffer_index >= last
		then goto fixed_zero;
	     end;
	else if substr (rest_of_field, 1, 1) = "+"
	then do;
		buffer_index = buffer_index + 1;
		if buffer_index >= last
		then goto fixed_zero;
	     end;

	if verify (rest_of_field, " 0123456789") - 1 >= 0
	then do;
		buffer_index = buffer_index + (verify (rest_of_field, " 0123456789") - 1);
		call bad_char;
	     end;

/*  Leading spaces and zeroes are not significant:  Skip them.  */
	i = verify (rest_of_field, " 0") - 1;
	if i < 0
	then goto fixed_zero;
	buffer_index = buffer_index + i;

	call right_justify (addr (rest_of_field), length (rest_of_field), addr (number.digit), max_fixed, prec);
						/*  Store significant digits in 'dec_int'.  */
	fio_ps.element_p -> words (1) = convert (my_code, dec_int);
						/* Convert decimal to binary. */
	goto countdown_element;


unpack_format (31):
unpack_format (32):
unpack_format (34):
unpack_format (36):
	call unpack_three;
	infinite_format = "0"b;
format_routine (31):				/* input f-format */
format_routine (32):				/* input e-format */
format_routine (34):				/* input d-format */
format_routine (36):				/* input g-format */
						/* Convert external value to either single or double precision float binary.  The
   precision of the float decimal source is derived from the external field, however a
   float dec(59) field is used for the conversion. There is no reason to translate blanks
   to zeros while creating the decimal value because the hardware treats blanks as zeros
   in decimal numbers.  In ansi77, if we want blanks treated as null, we do it  ourselves. */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call read_buffer;
	begin_index = buffer_index;			/* For error message. */
	i = verify (substr (rest_of_field, 1, field.width), " ") - 1;
	if i < 0
	then do;
store_zero:
		if fio_ps.double
		then fio_ps.element_p -> based_dp = 0.0;
		else fio_ps.element_p -> float_bin = 0.0;
		goto countdown_element;
	     end;
	buffer_index = buffer_index + i;

	dec_flt = 0.0;
	if substr (rest_of_field, 1, 1) = "-"
	then do;
		substr (work, 1, 4) = "-000";
		buffer_index = buffer_index + 1;
		if buffer_index >= last
		then goto store_zero;
	     end;
	else if substr (rest_of_field, 1, 1) = "+"
	then do;
		buffer_index = buffer_index + 1;
		if buffer_index >= last
		then goto store_zero;
	     end;

/*  Leading spaces and zeroes are not significant:  Skip them.  */
	i = verify (rest_of_field, " 0") - 1;
	if i < 0
	then goto store_zero;
	buffer_index = buffer_index + i;

/* "e" will be reset if there is a decimal point, otherwise, the value of d will be used.
   "exp" will be reset if there is an exponent, otherwise, the value of the scale will be used. */
	e = field.precision;
	exp = -FORMAT.scale;

/* Get any digits which appear before the decimal point. */
	l = verify (rest_of_field, " 0123456789") - 1;
	if l ^= 0					/* Found some digits. */
	then do;
		if l < 0
		then l = length (rest_of_field);
		call left_justify (addr (rest_of_field), (l), addr (number.digit), max_float, prec);
		buffer_index = buffer_index + l;
		if last - buffer_index = 0
		then go to finish_float;
	     end;
	else prec = 0;				/*  No digits yet.  */

/* Check for decimal point. If it exists, skip it and concatenate any digits which may follow it. */
	ch = substr (rest_of_record, 1, 1);
	if ch = "."
	then do;
		buffer_index = buffer_index + 1;	/* Skip over it. */
		e = 0;				/* The exponent if "." is last char in field. */
		if last - buffer_index <= 0
		then go to finish_float;

/*  Set 'l' to the size of the fraction part (i.e. the number of spaces and  */
/*  digits after the decimal point) and process it.                          */
		l = verify (rest_of_field, " 0123456789") - 1;
		if l ^= 0				/* Digits after the decimal point. */
		then do;
			if l < 0
			then l = last - buffer_index;

/*  Trailing spaces and zeroes in the fraction part are not significant.  If */
/*  the fraction part is all zeroes and spaces, ignore it; otherwise set 'j' */
/*  to the number of trailing zeroes and spaces and process it.              */
			j = verify (reverse (substr (rest_of_field, 1, l)), " 0") - 1;
			if j >= 0
			then do;			/*  There is at least 1 significant digit.  */

/*  If there were any significant digits before the decimal point, then all  */
/*  but the last 'j' digits of the fraction part are significant.  But if    */
/*  there were no significant digits before the decimal, leading spaces and  */
/*  zeroes in the fraction part are not significant.  Set 'i' to the number  */
/*  of insignificant leading digits and spaces in the fraction part.  Set    */
/*  'e' to the number of decimal places before the first significant digit   */
/*  of the fraction part.                                                  */
				if prec = 0	/* There were no digits before the decimal point. */
				then do;
					i = verify (substr (rest_of_record, 1, l - j), " 0") - 1;
					if i < 0
					then i = l - j;
					e = i;
					if blanks_as_null
					then do k = 1 to i;
						if substr (rest_of_field, k, 1) = " "
						then e = e - 1;
					     end;
				     end;
				else i = 0;
				call left_justify (addr (substr (rest_of_field, i + 1)), l - i - j,
				     addr (substr (number.digit, prec + 1)), max_float - prec, str_len);
				e = e + str_len;
				prec = prec + str_len;
			     end;
			buffer_index = buffer_index + l;
			if last - buffer_index = 0
			then go to finish_float;
		     end;
		ch = substr (rest_of_record, 1, 1);
	     end;

/* Either we have an exponent field or a syntax error. */
	exp = 0;					/* Wipe out scale factor. */
	dexp = 0;					/* Zero this field for expon conversion. */
	if index (exps, ch) ^= 0
	then do;
		buffer_index = buffer_index + 1;
		if last - buffer_index = 0
		then call syntax_error;		/* "e" as last character in field */
		i = verify (rest_of_field, " ");
		if i = 0
		then go to finish_float;
		buffer_index = buffer_index + i - 1;
		ch = substr (rest_of_record, 1, 1);
	     end;
	if ch = "+"
	then do;
		buffer_index = buffer_index + 1;
		if buffer_index = last
		then call syntax_error;		/* "+" as last character */
	     end;
	else if ch = "-"
	then do;
		substr (addr (dexp) -> chars, 1, 4) = "-000";
		buffer_index = buffer_index + 1;
		if buffer_index = last
		then call syntax_error;		/* "-" is the last char */
	     end;

/* At this point we had better have digits or else the end of the field. */

	if verify (rest_of_field, " 0123456789") - 1 >= 0
	then do;
		buffer_index = buffer_index + (verify (substr (rest_of_field, 1, prec), " 0123456789") - 1);
		call bad_char;
	     end;

/*  Leading spaces and zeroes are not significant:  Skip them.  */
	i = verify (rest_of_field, " 0") - 1;
	if i < 0
	then goto finish_float;
	buffer_index = buffer_index + i;

/*  Store the digits of the exponent in 'dexp', then assign it to 'exp'.  */
	call right_justify (addr (rest_of_field), length (rest_of_field), addr (substr (addr (dexp) -> chars, 2)), 3,
	     str_len);
	exp = dexp;

finish_float:
	if prec = 0
	then go to store_zero;
	e = exp - e + prec - max_float;

	if e >= 255
	then call conversion_error;
	else if e <= -256
	then call conversion_error;

	flt_dec.exp = e;

	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	if fio_ps.double
	then bin_type = bin_type + 1;
	call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work),
	     ext_float_decimal, (max_float));
	goto countdown_element;


unpack_format (33):
	call unpack_two;
	infinite_format = "0"b;
format_routine (33):				/* input l-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call read_buffer;

	i = verify (substr (rest_of_field, 1, field.width), " ");

	logical = "0"b;
	if i > 0
	then do;
		if substr (rest_of_field, i, 1) = "t" | substr (rest_of_field, i, 1) = "T"
		then logical = "1"b;
		else if substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".t"
		     | substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".T"
		then logical = "1"b;
	     end;
	goto countdown_element;


unpack_format (35):
	call unpack_two;
	infinite_format = "0"b;
format_routine (35):				/* input o-format */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call read_buffer;

	begin_index = buffer_index;			/* For error message. */
	i = verify (substr (rest_of_field, 1, field.width), " ") - 1;
	if i < 0
	then do;
		if fio_ps.double
		then fio_ps.element_p -> double_word = 0;
		else fio_ps.element_p -> words (1) = 0;
		goto countdown_element;
	     end;
	buffer_index = buffer_index + i;

	if substr (rest_of_field, 1, 1) = "-"
	then do;
		buffer_index = buffer_index + 1;
		negate = -1;
	     end;
	else if substr (rest_of_field, 1, 1) = "+"
	then do;
		buffer_index = buffer_index + 1;
		negate = 0;
	     end;
	else negate = 0;

	addr (work) -> double_word = 0;
	in = (24 - (last - buffer_index)) * 3;

	do buffer_index = buffer_index to last - 1;
	     ch = substr (rest_of_record, 1, 1);
	     if ch ^= " "
	     then do;
		     base = index ("01234567", ch) - 1;
		     if base < 0
		     then call bad_char;
		     if in >= 0
		     then substr (addr (work) -> based_bits, in + 1, 3) = bit (base, 3);
		end;
	     in = in + 3;
	end;

	if negate < 0
	then addr (work) -> double_word = -addr (work) -> double_word;
	if fio_ps.double
	then fio_ps.element_p -> double_word = addr (work) -> double_word;
	else fio_ps.element_p -> words (1) = addr (work) -> words (2);
	goto countdown_element;



unpack_format (7):
unpack_format (8):
unpack_format (37):
unpack_format (38):
format_routine (37):
format_routine (38):				/* Illegal types. */
format_routine (7):
format_routine (8):
	call print_error (fortran_io_error_$fio_sys_error, me, "Invalid format.");


unpack_format (39):
	call unpack_two;
	infinite_format = "0"b;
format_routine (39):				/* Input "r" format. */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call read_buffer;
	if field.width - char_len >= 0
	then do;
		buffer_index = buffer_index + (field.width - char_len);
		in = char_len;
		j = 0;
	     end;
	else do;
		in = field.width;
		unspec (substr (fio_ps.element_p -> chars, 1, char_len)) = "0"b;
		j = char_len - field.width;
	     end;
	substr (fio_ps.element_p -> chars, j + 1, in) = substr (rest_of_record, 1, in);
	go to countdown_element;


unpack_format (9):
	call unpack_two;
	infinite_format = "0"b;
format_routine (9):					/* Output "r" format. */
	if element_count = 0
	then go to fmt_done;
	last = last + field.width;
	call expand_buffer;
	if field.width - char_len > 0
	then do;
		substr (rest_of_record, 1, field.width - char_len) = " ";
		buffer_index = buffer_index + (field.width - char_len);
		j = 0;
	     end;
	else j = char_len - field.width;
	substr (rest_of_record, 1, char_len - j) = substr (fio_ps.element_p -> chars, j + 1, char_len - j);
	go to countdown_element;


unpack_format (10):
	call unpack_two;
	effective_digits = field.width;
	infinite_format = "0"b;
format_routine (10):				/* Output "a" format. */
	if element_count = 0
	then go to fmt_done;

/* since width must ALWAYS be positive, a ZERO value means use unspecified a_format, 
   i.e., let the width of the field be the number of characters in the data item */
	if field.width = 0
	then effective_digits = char_len;
	last = last + effective_digits;
	call expand_buffer;

	if effective_digits - char_len > 0
	then do;
		substr (rest_of_record, 1, effective_digits - char_len) = " ";
		buffer_index = buffer_index + (effective_digits - char_len);
		i = char_len;
	     end;
	else i = effective_digits;
	substr (rest_of_record, 1, i) = substr (fio_ps.element_p -> chars, 1, i);
	go to countdown_element;


unpack_format (40):
	call unpack_two;
	effective_digits = field.width;
	infinite_format = "0"b;
format_routine (40):				/* Input "a" format. */
	if element_count = 0
	then go to fmt_done;
	if field.width = 0				/* see comment on output for signifigance */
	then effective_digits = char_len;
	last = last + effective_digits;
	call read_buffer;

	if effective_digits - char_len > 0
	then do;
		buffer_index = buffer_index + (effective_digits - char_len);
		in = char_len;
	     end;
	else in = effective_digits;
	substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, in);
	go to countdown_element;


unpack_format (11):
unpack_format (19):
	call unpack_two;
format_routine (11):				/* Output hollerith field. */
format_routine (19):
	last = last + field.rep_factor;
	call expand_buffer;
	substr (rest_of_record, 1, field.rep_factor) = substr (in_fmt, field.width, field.rep_factor);
	buffer_index = last;
	goto get_next_format;


unpack_format (41):
unpack_format (49):
	call unpack_two;
format_routine (41):				/* Input hollerith field. */
format_routine (49):
	last = last + field.rep_factor;
	call read_buffer;
	substr (in_fmt, field.width, field.rep_factor) = substr (rest_of_record, 1, field.rep_factor);
	buffer_index = last;
	goto get_next_format;


unpack_format (42):
unpack_format (12):
	call unpack_one;
format_routine (42):				/*  Input X format.  */
format_routine (12):				/*  Output X format.  */
	last = last + field.rep_factor;
	if op_offset = WRITE_ & ^fio_ps.ansi_77
	then do;					/* Transmit specified number of spaces. */
		call expand_buffer;
		substr (rest_of_record, 1, field.rep_factor) = "";
	     end;
	buffer_index = last;
	goto get_next_format;


unpack_format (43):
unpack_format (51):
unpack_format (13):
unpack_format (21):
	call unpack_two;
format_routine (43):				/*  Input T format.  */
format_routine (51):				/*  Input TL or TR formats.  */
format_routine (13):				/*  Output T format.  */
format_routine (21):				/*  Output TL or TR formats.  */
	if field.spec = t_format | field.spec = t_format + op_offset
	then last = field.width - 1 + column_one;
	else last = max (column_one, field.width + last);
	if op_offset = WRITE_ & ^fio_ps.ansi_77
	then call read_buffer;
	buffer_index = last;
	goto get_next_format;


unpack_format (14):
unpack_format (44):
	call unpack_one;
format_routine (44):				/* Process scale factor here. */
format_routine (14):
	FORMAT.scale = field.rep_factor;
	go to get_next_format;


unpack_format (15):
unpack_format (45):
	call unpack_one;
format_routine (45):
format_routine (15):				/* "(" Check maximum level of parentheses. */
	FORMAT.paren_level = FORMAT.paren_level + 1;
	if FORMAT.paren_level > hbound (FORMAT.restart, 1)
	then call print_error (fortran_io_error_$parens_too_deep, me, "Maximum is ^d.", hbound (FORMAT.restart, 1));

	FORMAT.rep_factor (FORMAT.paren_level) = field.rep_factor;
	FORMAT.restart (FORMAT.paren_level) = FORMAT.indx;
	go to get_next_format;


unpack_format (16):
unpack_format (46):
format_routine (46):
format_routine (16):				/* ")" Bump counter and move on if done. */
	if FORMAT.paren_level <= 0
	then goto get_next_format;
	FORMAT.rep_factor (FORMAT.paren_level) = FORMAT.rep_factor (FORMAT.paren_level) - 1;
	if FORMAT.rep_factor (FORMAT.paren_level) <= 0
	then FORMAT.paren_level = FORMAT.paren_level - 1;
	else FORMAT.indx = FORMAT.restart (FORMAT.paren_level);
	go to get_next_format;

countdown_element:
	element_count = element_count - 1;
	call advance_element_p;
	buffer_index = last;
	field.rep_factor = field.rep_factor - 1;
	if field.rep_factor <= 0
	then goto get_next_format;
	go to format_routine (field.spec);


unpack_format (18):
unpack_format (48):
format_routine (48):				/* :-format */
format_routine (18):
	if element_count = 0
	then go to fmt_done;
	go to get_next_format;


unpack_format (50):
format_routine (50):				/* End of format statement for input. */
	if element_count = 0
	then goto fmt_done;
	if infinite_format
	then call print_error (fortran_io_error_$format_is_infinite);
	infinite_format = "1"b;
	FORMAT.indx = format_p -> runtime_format.last_left_paren;
	FORMAT.paren_level = 0;


unpack_format (47):
format_routine (47):				/* "/" Start a new input record. */
	call read_a_record;
	buffer_index, last = 0;
	if skip_line_numbers
	then call strip_line_no (/* buffer_index, last */);
	goto get_next_format;


unpack_format (20):
format_routine (20):				/* End of format statement for output. */
	if element_count = 0
	then do;
fmt_done:
		return;
	     end;
	if infinite_format
	then call print_error (fortran_io_error_$format_is_infinite);
	infinite_format = "1"b;
	FORMAT.indx = format_p -> runtime_format.last_left_paren;
	FORMAT.paren_level = 0;
	if suppress_final_newline
	then go to get_next_format;


unpack_format (17):
format_routine (17):				/* "/" Start a new output record. */
	call write_a_record;
	buffer_index, last = buffer_length;
	goto get_next_format;

unpack_format (25):
unpack_format (55):
format_routine (25):
format_routine (55):				/* BN format - treat blanks as null */
	blanks_as_null = "1"b;
	goto get_next_format;

unpack_format (26):
unpack_format (56):
format_routine (26):
format_routine (56):				/* BZ format - treat blanks as zero */
	blanks_as_null = "0"b;
	goto get_next_format;

unpack_format (27):
unpack_format (57):
format_routine (27):				/* S format (ansi77) */
format_routine (57):				/* leading plus sign on output processor dependent */
	must_produce_plus = "0"b;
	goto get_next_format;

unpack_format (28):
unpack_format (58):
format_routine (28):				/* SP format (ansi77) */
format_routine (58):				/* leading plus sign required on output */
	must_produce_plus = "1"b;
	goto get_next_format;

unpack_format (29):
unpack_format (59):
format_routine (29):				/* SS format (ansi77) */
format_routine (59):				/* leading plus sign forbidden on output */
	must_produce_plus = "0"b;
	goto get_next_format;

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

print_zero:
	call minus_sign;				/* all relevant values are already calculated */

	if add_zero				/* also calculated */
	then do;
		substr (rest_of_record, 1, 1) = "0";
		buffer_index = buffer_index + 1;
	     end;

	substr (rest_of_record, 1, 1) = ".";

	if field.precision > 0
	then substr (rest_of_record, 2, field.precision) = copy ("0", field.precision);

	buffer_index = buffer_index + (field.precision + 1);
	if buffer_index = last
	then goto countdown_element;			/* f-format exits here */

	if FORMAT.scale > 0 & field.precision ^= 0
	then substr (rest_of_field, 1, 1) = "0";

	if field.spec = d_format
	then substr (io_buf, last - digits_after_E - 1, 2) = "D+";
	else substr (io_buf, last - digits_after_E - 1, 2) = "E+";
	substr (io_buf, last - digits_after_E + 1, digits_after_E) = copy ("0", digits_after_E);
	goto countdown_element;

print_stars:
	substr (rest_of_field, 1, field.width) = copy ("*", field.width);
	go to countdown_element;

print_blanks:
	substr (rest_of_field, 1, field.width) = copy (SP, field.width);
	go to countdown_element;

/*	Entry to initialize formatted I/O. */

initialize_formatted_io:
     entry;

	if fio_ps.read
	then buffer_index = 0;			/* Must be set before call to print_error */

	if PS.user_format_p -> runtime_format.version = fmt_parse_ver1
	then format_p = PS.user_format_p;
	else do;
		call general_format_parse_$runtime (in_fmt, work_str, (fio_ps.ansi_77), my_code);

		if my_code ^= 0
		then call print_error (fortran_io_error_$format_error, me, "^a^/""^a""",
			addr (work_str) -> error_message, substr (in_fmt, 1, addr (work_str) -> input_length));
		else format_p = addr (work_str);
	     end;

	have_runtime_format = "1"b;

	skip_line_numbers = format_p -> runtime_format.skip_line_numbers;

	if format_p -> runtime_format.suppress_newline
	then suppress_final_newline = "1"b;

	must_produce_plus = "0"b;
	blanks_as_null = file_desc.blank_null;

	if format_p -> runtime_format.list_directed	/* If v-format then this is list-directed I/O */
	then do;
		if fio_ps.read
		then if skip_line_numbers
		     then call strip_line_no ();

		go to initiate_routine (0);
	     end;


	if fio_ps.list & ^format_p -> runtime_format.anyitems
						/* format would loop forever */
	then call print_error (fortran_io_error_$format_is_infinite);


/* Initialize local variables. */

	buffer_index = 0;				/* Must be set before call to strip_line_no */
	last = 0;
	FORMAT.indx = 1;
	FORMAT.paren_level = 0;
	FORMAT.scale = 0;
	element_count = 0;
	infinite_format = "0"b;

	if fio_ps.read
	then do;
		if skip_line_numbers
		then call strip_line_no (/* buffer_index, last */);
		op_offset = READ_;
		overflow_label = conversion_error_handler;
		zero_label = no_handler;
	     end;
	else do;
		if skip_line_numbers
		then call print_error (fortran_io_error_$format_error, me,
			"Line number stripping only allowed during input.");
		op_offset = WRITE_;
		overflow_label = print_stars;
		zero_label = print_stars;
	     end;
	goto get_next_format;

/* Internal procedures to unpack format specifiactions. */

unpack_one:
     proc;
	if fmt_ptr -> format.long_format
	then field.rep_factor = fmt_ptr -> long_format.rep_factor;
	else field.rep_factor = fmt_ptr -> format.rep_factor;
     end unpack_one;

unpack_two:
     proc;
	if fmt_ptr -> format.long_format
	then do;
		FORMAT.indx = FORMAT.indx + 1;
		field.rep_factor = fmt_ptr -> long_format.rep_factor;
		field.width = fmt_ptr -> long_format.width;
	     end;
	else do;
		field.rep_factor = fmt_ptr -> format.rep_factor;
		field.width = fmt_ptr -> format.width;
	     end;
     end unpack_two;

unpack_three:
     proc;
	if fmt_ptr -> format.long_format
	then do;
		FORMAT.indx = FORMAT.indx + 1;
		field.rep_factor = fmt_ptr -> long_format.rep_factor;
		field.width = fmt_ptr -> long_format.width;
		field.precision = fmt_ptr -> long_format.precision;
	     end;
	else do;
		field.rep_factor = fmt_ptr -> format.rep_factor;
		field.width = fmt_ptr -> format.width;
		field.precision = fmt_ptr -> format.precision;
	     end;
     end unpack_three;

unpack_four:
     proc;
	if fmt_ptr -> format.long_format
	then do;
		FORMAT.indx = FORMAT.indx + 1;
		field.rep_factor = fmt_ptr -> long_format.rep_factor;
		field.width = fmt_ptr -> long_format.width;
		field.precision = fmt_ptr -> long_format.precision;
		field.exponent = fmt_ptr -> long_format.exponent;
	     end;
	else do;
		field.rep_factor = fmt_ptr -> format.rep_factor;
		field.width = fmt_ptr -> format.width;
		field.precision = fmt_ptr -> format.precision;
		field.exponent = 0;
	     end;
     end unpack_four;


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

/*	Internal procedures to convert from binary to character under format control. */

start_floating:
     proc;
	if negate ^= 0
	then leading_sign = MINUS_SIGN;
	else if must_produce_plus
	then do;
		negate = 1;
		leading_sign = PLUS_SIGN;
	     end;

/* Check if there is room for a leading zero. */
	i = field.precision + i + negate;
	if i > field.width
	then go to print_stars;
	if i < field.width
	then do;
		add_zero = "1"b;
		i = i + 1;
	     end;
	else add_zero = "0"b;
     end start_floating;


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

create_decimal:
     proc;

	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	if fio_ps.double
	then bin_type = bin_type + 1;

	if prec <= 0 | prec > max_float
	then go to print_stars;
	call assign_round_ (addr (work), decimal_type, decimal_len, fio_ps.element_p, binary_type (bin_type),
	     binary_prec (bin_type));
	count = verify (number.digit, "0") - 1;
	if count < 0
	then go to print_zero;
     end create_decimal;


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

minus_sign:
     proc;
	if field.width - i > 0
	then do;
		substr (rest_of_record, 1, field.width - i) = " ";
		buffer_index = buffer_index + (field.width - i);
	     end;

/* Put out leading sign if it is required. */

	if negate ^= 0
	then do;
		substr (rest_of_record, 1, 1) = leading_sign;
		buffer_index = buffer_index + 1;
	     end;
     end minus_sign;


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

/* Internal procedure to maintain output buffer size and incidentally detect some end of file conditions in internal_files */

expand_buffer:
     proc;

	if last > buffer_max_len
	then if fio_ps.mode = internal_file & internal_file_count <= 0
	     then call internal_file_overflow;
	     else call too_much_output;
	if last > buffer_length
	then do;
		if buffer_index > buffer_length
		then substr (io_buf, buffer_length + 1, buffer_index - buffer_length) = "";
		buffer_length = last;
	     end;
     end expand_buffer;


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

/*	Internal procedure to grow a read buffer and blank the grown area. */

read_buffer:
     proc;

	if last > buffer_max_len
	then if op_offset = WRITE_
	     then call too_much_output;
	     else call too_much_input;
	if last <= buffer_length
	then return;
	substr (io_buf, buffer_length + 1, last - buffer_length) = " ";
	buffer_length = last;

     end read_buffer;

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

/*  Internal procedure to store a given character string left justified in   */
/*  another string, with spaces optionally deleted.                          */

left_justify:
     proc (source_ptr, source_len, result_ptr, result_len, chars_stored);

	dcl     source_ptr		 ptr,		/*  Address of source string.  */
	        source_len		 fixed bin,	/*  Length of source string.  */
	        result_ptr		 ptr,		/*  Address of result string.  */
	        result_len		 fixed bin,	/*  Length of result string.  */
	        chars_stored	 fixed bin;	/*  Number of chars stored in result.  */

	dcl     piece_len		 fixed bin,
	        source_idx		 fixed bin;

	dcl     result		 char (result_len) based (result_ptr),
	        source		 char (source_len) based (source_ptr);

	chars_stored = 0;
	if blanks_as_null
	then do source_idx = source_len + 1 - length (ltrim (source))
		repeat source_len + 1 - length (ltrim (substr (source, source_idx + piece_len)))
		while (source_idx <= source_len);
		piece_len = length (before (substr (source, source_idx), " "));
		if chars_stored + piece_len > result_len
		then call conversion_error;
		substr (result, chars_stored + 1, piece_len) = substr (source, source_idx, piece_len);
		chars_stored = chars_stored + piece_len;
	     end;
	else do;
		if source_len > result_len
		then call conversion_error;
		substr (result, 1, source_len) = source;
		chars_stored = source_len;
	     end;
     end left_justify;

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

/*  Internal procedure to store a given character string right justified in  */
/*  another string, optionally deleting spaces.                              */

right_justify:
     proc (source_ptr, source_len, result_ptr, result_len, chars_stored);

	dcl     source_ptr		 ptr,		/*  Address of source string.  */
	        source_len		 fixed bin,	/*  Length of source string.  */
	        result_ptr		 ptr,		/*  Address of result string.  */
	        result_len		 fixed bin,	/*  Length of result string.  */
	        chars_stored	 fixed bin;	/*  Number of chars stored in result.  */

	dcl     piece_len		 fixed bin,
	        source_limit	 fixed bin;

	dcl     result		 char (result_len) based (result_ptr),
	        source		 char (source_len) based (source_ptr);

	chars_stored = 0;
	if blanks_as_null
	then do source_limit = length (rtrim (source))
		repeat length (rtrim (substr (source, 1, source_limit - piece_len))) while (source_limit > 0);
		piece_len = length (before (reverse (substr (source, 1, source_limit)), " "));
		if chars_stored + piece_len > result_len
		then call conversion_error;
		chars_stored = chars_stored + piece_len;
		substr (result, result_len + 1 - chars_stored, piece_len) =
		     substr (source, source_limit + 1 - piece_len, piece_len);
	     end;
	else do;
		if chars_stored > result_len
		then call conversion_error;
		substr (result, result_len + 1 - source_len, source_len) = source;
		chars_stored = source_len;
	     end;
     end right_justify;

     end formatted_io;

/* Namelist and list-directed I/O */
namelist_io:
     proc;

	dcl     string		 builtin;		/* To override some structure declarations. */

	dcl     1 ok_list		 aligned based (ok_pt),
		2 number		 fixed bin,
		2 list		 (100) fixed bin (17) unal,
	        1 acc		 aligned based,
		2 name_size	 unal bit (9),
		2 name_string	 char (name_ln) unal,
	        (headings, rep_factor, namelist, comma_encountered, comma_required, legal_end, null_value)
				 bit (1) aligned,
	        (name_ln, dims)	 fixed bin (18);
	dcl     temp		 fixed bin (21);
	dcl     c_temp		 (2) float bin (27);
	dcl     factor		 fixed bin (18);
	dcl     stu_$get_runtime_address
				 ext entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr),
	        stu_$find_runtime_symbol
				 ext entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr),
	        stu_$decode_runtime_value
				 entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin (35))
				 returns (fixed bin (35));

	dcl     namelist_name_len	 fixed bin,
	        namelist_name	 char (namelist_name_len) based (namelist_name_ptr);
	dcl     integer		 fixed bin (35) aligned based,
						/* for integer variables */
	        logical		 bit (1) aligned based,
						/* for logical variables */
	        1 complex_value	 aligned based,
		2 real		 float bin (27),
		2 imag_part	 float bin (27);
	dcl     (data_type, constant_type)
				 fixed bin (6),
	        (
	        integer_type	 fixed bin (6) init (1),
	        real_type		 fixed bin (6) init (2),
	        double_type		 fixed bin (6) init (3),
	        complex_type	 fixed bin (6) init (4),
	        logical_type	 fixed bin (6) init (5),
	        character_type	 fixed bin (6) init (6),
	        headers		 char (2) init ("$&"),
	        delims		 char (5) init (" 	,/;"),
						/* SP TAB , / ; */
	        alphameric		 char (64)
				 init ("0123456789$_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"),
	        digits		 char (10) init ("0123456789"),
	        numerics		 char (13) init ("+-0123456789."),
	        log		 char (4) init ("tfTF")
	        )			 aligned int static options (constant),
	        runtime_table	 (48) aligned fixed bin (6) internal static options (constant)
				 init (1, 0, 2, 3, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 6, 0, 0, 0, 0,
				 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3);
	dcl     (n, subscripts)	 fixed bin (18);
	dcl     subscript_array	 (7) fixed bin (18);
	dcl     repetition_count	 fixed bin (18);


%include runtime_symbol;

/* Put useful information into automatic storage. */

	ok_pt = PS.namelist_p;			/* Pointer to namelist list of variables. */
	sp = PS.stack_frame_p;			/* Stack frame pointer. */
	table_pt = PS.symbol_table_top_p;		/* Symbol table pointer. */
	text_pt, link_pt = null;
	buffer_index = 0;				/* Index for substr. */

	namelist = "1"b;				/* Tell the utilities who we are. */

/* Pick up namelist name. */

	symbol_pt, block_pt = addrel (table_pt, ok_list.list (1));

/* Pick up block pointer from namelist symbol.  Otherwise block is possibly
   incorrect. bug 372. Scan entries until we get the right level. */

	if fixed (block_pt -> runtime_symbol.level, 6, 0) <= 1
	then block_pt = addrel (block_pt, block_pt -> runtime_symbol.father);
	else do while (fixed (block_pt -> runtime_symbol.level, 6, 0) > 1);
		block_pt = addrel (block_pt, block_pt -> runtime_symbol.father);
	     end;

/* Decide on direction of transmission. */
	if fio_ps.read
	then go to read;

/* Set format control switches for output. */
	headings = ^(file_desc.printer_file & file_desc.carriage_controllable);

/* Create and output a header record if this is not a print file. */
	if headings
	then do;

		name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name);
		name_ln = fixed (name_pt -> acc.name_size, 9);

		if buffer_length + (name_ln + 2) > buffer_max_len
		then call too_much_output;
		substr (rest_of_output, 1, name_ln + 2) = "$" || name_pt -> acc.name_string || SP;
		buffer_length = buffer_length + (name_ln + 2);
	     end;
	else do;
		if buffer_length = buffer_max_len
		then call too_much_output;
		substr (rest_of_output, 1, 1) = SP;
		buffer_length = buffer_length + 1;
	     end;

/* Go through and print everybody. */
	do count = 2 to ok_pt -> ok_list.number;

/* Pick up variable name and print it. */
	     symbol_pt = addrel (table_pt, ok_list.list (count));
	     subs_pt = null;			/* May have been set by last variable. */
	     call decode_runtime;

	     if buffer_length + (name_ln + 3) > buffer_max_len
	     then call too_much_output;
	     substr (rest_of_output, 1, name_ln + 3) = name_pt -> acc.name_string || " = ";
	     buffer_length = buffer_length + (name_ln + 3);


/* Print out all the elements. */
	     do n = 1 to element_count;
		if fio_ps.ansi_77
		then call ansi77_output;		/*  Use '77 style of output.  */
		else call ansi66_output;		/*  Use '66 style of output.  */

		if count ^= ok_pt -> ok_list.number | n ^= element_count
		then do;
			if buffer_length >= buffer_max_len - 1
			then call too_much_output;
			if headings
			then substr (rest_of_output, 1, 2) = ",";
			else substr (rest_of_output, 1, 2) = " ";
			if fio_ps.ansi_77
			then buffer_length = buffer_length + 2;
			else buffer_length = buffer_length + 1;
		     end;
	     end;

	end;					/*Loop through namelist. */

/* Output trailer if necessary. */
	if headings
	then do;
		if buffer_length = buffer_max_len
		then call too_much_output;
		substr (rest_of_output, 1, 1) = "$";
		buffer_length = buffer_length + 1;
	     end;

	return;


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

/*	Namelist input. */
read:
	constant_ptr = addr (work_str);
	count_pt = null;

	name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name);
	namelist_name_len = fixed (name_pt -> acc.name_size, 9);
	namelist_name_ptr = addr (name_pt -> acc.name_string);

/* Find header record. */

find_header:
	call get_field;

	if index (headers, substr (rest_of_record, 1, 1)) = 0
	then go to missing_header;
	else buffer_index = buffer_index + 1;

	if buffer_length - buffer_index < namelist_name_len
	then do;
missing_header:
		call print_error (fortran_io_error_$missing_header, me, """$^a""", namelist_name);
		call buffer_read;
		go to find_header;
	     end;

	if substr (rest_of_record, 1, namelist_name_len) ^= namelist_name
	then do;
		if ^fio_ps.fold
		then go to missing_header;		/* Must match exactly */
		if translate (substr (rest_of_record, 1, namelist_name_len), lower_letters, capital_letters)
		     ^= namelist_name
		then go to missing_header;
	     end;

	buffer_index = buffer_index + namelist_name_len;

/* Insure we don't have a substr of something else. */
	call check_end;
	if ^legal_end
	then go to missing_header;

/* Get the next variable or return. */

get_name:
	call get_field;

/* check for end of namelist input. */

	if index (headers, substr (rest_of_record, 1, 1)) ^= 0
	then if count_pt = null
	     then do;
		     fio_ps.have_input = "0"b;	/* no longer relevant */
		     return;
		end;
	     else call print_error (fortran_io_error_$syntax_error, me, "No variable follows ""/"".");

	i = verify (rest_of_record, alphameric) - 1;
	if i < 0
	then i = buffer_length - buffer_index;
	else if i = 0
	then call print_error (fortran_io_error_$syntax_error, me, "Variable name is missing.");

/* Look it up in the runtime symbol tables. */
	symbol_pt = stu_$find_runtime_symbol (block_pt, substr (rest_of_record, 1, i), null, 0);
	if symbol_pt = null
	then do;
		if ^fio_ps.fold			/* If symbols not folded */
		then
symbol_abort:
		     call print_error (fortran_io_error_$namelist_error, me, "^a is not a member of $^a.",
			substr (rest_of_record, 1, i), namelist_name);
		symbol_pt =
		     stu_$find_runtime_symbol (block_pt,
		     translate (substr (rest_of_record, 1, i), lower_letters, capital_letters), null (), 0);
		if symbol_pt = null ()
		then go to symbol_abort;		/* Couldn't find it folded, either */
	     end;

	do k = 2 to ok_pt -> ok_list.number;
	     if addrel (table_pt, ok_list.list (k)) = symbol_pt
	     then go to legal_symbol;
	end;
	go to symbol_abort;

legal_symbol:
	buffer_index = buffer_index + i;
	call get_field;

/* Process "count variable" and save for later. */
	if count_pt = null
	then if ch = "/"
	     then do;
		     count_pt = symbol_pt;
		     buffer_index = buffer_index + 1;
		     call get_field;
		     go to get_name;
		end;

/* Process subscripts. */
	if ch = "("
	then do;
		subs_pt = addr (subscript_array);
		buffer_index = buffer_index + 1;
		do subscripts = 1 to 7;
		     call get_field;
		     call input_float;
		     if constant_type ^= integer_type
		     then go to bad_subs;
		     if constant_ptr -> integer = 0
		     then go to bad_subs;
		     subscript_array (subscripts) = constant_ptr -> integer;
		     call check_end;
		     if ^comma_encountered
		     then goto check_paren;
		end;

check_paren:
		if substr (rest_of_record, 1, 1) ^= ")"
		then call print_error (fortran_io_error_$syntax_error, me, "Missing "")"".");
		buffer_index = buffer_index + 1;
		call get_field;
	     end;
	else subscripts = 0;

/* Must have "=" here. */
	if ch ^= "="
	then call print_error (fortran_io_error_$syntax_error, me, "Missing ""="".");

	buffer_index = buffer_index + 1;

/* Validate subscripts.  Also supply subscripts the user may have omitted. */
	name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name);
	name_ln = fixed (name_pt -> acc.name_size, 9);
	i = fixed (symbol_pt -> runtime_symbol.ndims, 6);
	if subscripts > i
	then call print_error (fortran_io_error_$syntax_error, me, "More subscripts than dimensions for ^a.",
		name_pt -> acc.name_string);

	if subscripts > 0
	then do;
		do k = subscripts + 1 to i;		/* Fill in dimensions not specified. */
		     subscript_array (k) = 1;
		end;

		do k = 1 to divide (i, 2, 17, 0);	/* Reverse order for stu_. */
		     j = subscript_array (i - k + 1);
		     subscript_array (i - k + 1) = subscript_array (k);
		     subscript_array (k) = j;
		end;

		do k = 1 to subscripts;
		     l = stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (k).upper, block_pt, sp,
			link_pt, text_pt, null, my_code);
		     if my_code ^= 0
		     then
bound_error:
			call print_error (fortran_io_error_$syntax_error, me,
			     "Cannot get bounds information for ^a.", name_pt -> acc.name_string);
		     if subscript_array (k) > l
		     then
bad_subs:
			call print_error (fortran_io_error_$syntax_error, me,
			     "Subscript is out of range or invalid.");
		end;

	     end;
	else subs_pt = null;

/* Get symbol information. */
	call decode_runtime;

/* Read in and store values. */
	count = 0;

/* Input loop. */
	do while (element_count > 0);
	     factor = 1;
	     rep_factor = "0"b;

get_value:
	     call get_field;

	     if ch = ","
	     then do n = 1 to factor;
		     call store_null;
		end;
	     else do;
		     if index ("""'", ch) ^= 0
		     then call input_charstr;
		     else if ch = "("
		     then do;
			     call input_complex;
			end;
		     else if ch = "."
		     then do;
			     if buffer_index + 1 >= buffer_length
			     then call syntax_error;
			     if index (digits, substr (rest_of_record, 2, 1)) = 0
			     then call input_logical;
			     else call input_float;
			end;
		     else if index (log, ch) ^= 0
		     then do;
			     temp = buffer_index;	/* Check for end is just a heuristic... */
			     buffer_index = buffer_index + 1;
						/* must determine if "t" or "f" is value or variable */
			     call check_end;
			     buffer_index = temp;	/* restore to previous position */

			     if ^legal_end
			     then go to store_count;
			     call input_logical;
			end;
		     else if index (numerics, ch) ^= 0
		     then do;
			     call input_float;
			     if constant_type = integer_type
			     then if buffer_index < buffer_length
				then if substr (rest_of_record, 1, 1) = "*"
				     then do;
					     if rep_factor
					     then call bad_char;
					     rep_factor = "1"b;
					     factor = constant_ptr -> integer;
					     if factor <= 0
					     then call print_error (fortran_io_error_$syntax_error, me,
						     "Repetition count is less than one.");
					     if factor > element_count
					     then call print_error (fortran_io_error_$namelist_error, me,
						     "Repetition factor is greater than remaining elements.(^d > ^d).",
						     factor, element_count);
					     buffer_index = buffer_index + 1;
					     go to get_value;
					end;
				     else if index ("hH", substr (rest_of_record, 1, 1)) ^= 0
				     then do;
					     i = constant_ptr -> integer;
					     if i <= 0
					     then call print_error (fortran_io_error_$syntax_error, me,
						     "Hollerith constant length must be positive.");
					     str_len = 0;
					     buffer_index = buffer_index + 1;
						/* Skip "h". */
					     call build_string (i);
					end;
			end;
		     else if rep_factor
		     then call print_error (fortran_io_error_$syntax_error, me,
			     "No value follows a repetition factor.");
		     else go to store_count;

/* Store the constant. */
		     do n = 1 to factor;
			call store;
		     end;
		end;				/* Non-null constant. */

/* Common for all constants. Update various counts. */

	     call check_end;
	     if ^legal_end
	     then call bad_char;

	     element_count = element_count - factor;
	     count = count + factor;
	end;					/* Input loop. */

store_count:
	if count_pt ^= null
	then do;
		subs_pt = null;
		symbol_pt = count_pt;
		call decode_runtime;
		constant_ptr -> integer = count;
		dec_int = count;
		constant_type = integer_type;
		call store;
		count_pt = null;
	     end;
	go to get_name;


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

/*	List directed I/O entry points. */

list_io:
     entry;

	namelist = "0"b;				/* Tell utilities who we're not.*/

	data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0));
	call set_size_and_count (char_len, element_count, chars_per_item);

	if fio_ps.read
	then do;
		constant_ptr = addr (work_str);
		legal_end = "1"b;			/* First field is always ok. */
		do while (element_count > 0);

		     if repetition_count <= 0
		     then do;
			     call list_input ();	/* Read a value */
			end;

		     if null_value
		     then call store_null ();
		     else call store ();

		     element_count = element_count - 1;
		     repetition_count = repetition_count - 1;
		end;

		fio_ps.have_input = "0"b;

	     end;

/* List-directed output */

	else if fio_ps.ansi_77
	then do;					/*  Use '77 style of output.  */
		do n = 1 to element_count;
		     if data_type_of_prev_item ^= character_type & data_type ^= character_type
		     then do;			/*  Output a space for a separator.  */
			     if buffer_length >= buffer_max_len
			     then call too_much_output;
			     substr (rest_of_output, 1, 1) = " ";
			     buffer_length = buffer_length + 1;
			end;
		     call ansi77_output;
		     data_type_of_prev_item = data_type;
		end;
	     end;

	else do;					/*  Use '66 style of output.  */
		do n = 1 to element_count;
		     call ansi66_output;
		end;
	     end;

	return;


initialize_list_input:
     entry ();

	repetition_count = 0;
	null_value = "0"b;
	comma_required = "0"b;

	return;

/* Internal procedure to read list directed values. */

list_input:
     procedure ();

list_input_retry:
	call get_field;

/* check of end of list-directed input. */

	if ch = ";" | ch = "/"
	then do;
		fio_ps.have_input = "0"b;		/* no longer relevant */
		if fio_ps.ansi_77
		then do;
			fio_ps.end_of_input = "1"b;
			goto element_list_abort;	/* user has signalled end of input */
		     end;
		null_value = "1"b;			/* ensure 0 or blanks are assigned to the list element in ansi 66 mode */
		return;
	     end;

	if comma_required
	then if ch = ","
	     then do;
		     buffer_index = buffer_index + 1;
		     comma_required = "0"b;
		     go to list_input_retry;
		end;
	     else call print_error (fortran_io_error_$syntax_error, me,
		     "A non-blank delimiter is required after a repeated null value.");

	if ch = ","
	then do;
		buffer_index = buffer_index + 1;	/* Skip comma */
		null_value = "1"b;
		return;
	     end;

	null_value = "0"b;
	call check_repetition ();			/* Check for r*c or r* */
	if null_value
	then return;				/* r* form */

	go to free_input (data_type);

free_input (1):
free_input (2):
free_input (3):
	call input_float;
	goto free_delim;

free_input (4):					/* complex */
	if substr (rest_of_record, 1, 1) = "("
	then do;					/* complex constant */
		call input_complex;
	     end;

	else do;					/* or two integers or reals */
		do i = 1 to 2;

		     if buffer_index >= buffer_length
		     then call syntax_error;

		     if substr (rest_of_record, 1, 1) = ","
		     then do;
			     c_temp (i) = 0.0;	/* user omitted value */
			     buffer_index = buffer_index + 1;
						/* skip comma */
			     call check_end;	/* gets nexts no white */
			     if ^legal_end
			     then call bad_char;
			end;

		     else call input_piece_of_complex (c_temp (i), "0"b);

		     if comma_encountered
		     then buffer_index = buffer_index - 1;
		end;

		unspec (constant_ptr -> complex_value) = unspec (c_temp);
	     end;

	constant_type = complex_type;
	goto free_delim;

free_input (5):
	call input_logical;
	go to free_delim;

free_input (6):
	ch = substr (rest_of_record, 1, 1);
	if index ("""'", ch) ^= 0
	then call input_charstr;
	else do;
		i = search (rest_of_record, delims) - 1;
		if i < 0
		then i = buffer_length - buffer_index;
		str_len = 0;
		call build_string (i);
	     end;

free_delim:
	call check_end;
	if ^legal_end
	then call bad_char;				/* Insure previous field ended ok. */

	return;

     end list_input;

check_repetition:
     procedure ();

	repetition_count = 1;

	if index (digits, ch) = 0
	then return;

	i = verify (rest_of_record, digits);
	if i = 0
	then return;

	if substr (rest_of_record, i, 1) ^= "*"
	then return;

	call input_float ();
	repetition_count = constant_ptr -> integer;
	if repetition_count <= 0
	then call print_error (fortran_io_error_$syntax_error, me,
		"A repetition count in a list-directed input field must be greater than zero.");

	buffer_index = buffer_index + 1;		/* Skip * */

	call check_end ();
	if legal_end
	then do;
		null_value = "1"b;			/* r* form */
		comma_required = ^comma_encountered;
	     end;

     end check_repetition;

/*	Internal procedure to output values in 'ansi66' mode. */

ansi66_output:
     proc;

/* ansi66 output is formatted as  "bb-.v(18)9es99" for double precision and
   "bb-.v(8)9es99" for single precision numbers. */
	dcl     dp_pic_len		 fixed bin int static options (constant) init (26),
	        flt_pic_len		 fixed bin int static options (constant) init (16);

	dcl     single_precision	 bit (1) int static options (constant) init ("1"b),
	        double_precision	 bit (1) int static options (constant) init ("0"b);
	dcl     number_string	 char (26);

	go to output_format (data_type);

output_format (1):					/* Integers. */
	if buffer_length + length (int_pic) > buffer_max_len
	then call too_much_output;
	int_pic = fio_ps.element_p -> integer;
	substr (rest_of_output, 1, length (int_pic)) = int_pic;
	buffer_length = buffer_length + length (int_pic);
	go to output_return;

output_format (2):					/* Single precision real. */
	j = 3;
	if buffer_length + flt_pic_len > buffer_max_len
	then call too_much_output;

fake_complex:
	call ansi66_format (single_precision, fio_ps.element_p, number_string);
	substr (rest_of_output, 1, flt_pic_len) = substr (number_string, 1, flt_pic_len);
	buffer_length = buffer_length + flt_pic_len;
	go to real_part (j);

output_format (3):					/* Double precision real. */
	if buffer_length + dp_pic_len > buffer_max_len
	then call too_much_output;
	call ansi66_format (double_precision, fio_ps.element_p, number_string);
	substr (rest_of_output, 1, dp_pic_len) = number_string;
	buffer_length = buffer_length + dp_pic_len;
	go to output_return;

output_format (4):					/* Complex. */
	j = 1;
	if buffer_length + 2 * flt_pic_len + 5 > buffer_max_len
	then call too_much_output;

	substr (rest_of_output, 1, 2) = " (";
	buffer_length = buffer_length + 2;

	go to fake_complex;

real_part (1):					/* Append comma after real part for namelist. */
	substr (rest_of_output, 1, 2) = ", ";
	buffer_length = buffer_length + 2;
	fio_ps.element_p = addrel (fio_ps.element_p, 1);	/* Point to imaginary part.*/
	j = j + 1;				/*Next set of functions.*/
	go to fake_complex;

real_part (2):					/*Right paren for namelist.*/
	substr (rest_of_output, 1, 1) = ")";
	buffer_length = buffer_length + 1;
	fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */
	go to output_return;

output_format (5):					/* Logical */
	if buffer_length + 2 > buffer_max_len
	then call too_much_output;

	if fio_ps.element_p -> logical
	then substr (rest_of_output, 1, 2) = " T";
	else substr (rest_of_output, 1, 2) = " F";
	buffer_length = buffer_length + 2;
	go to output_return;

output_format (6):					/* Character */
	if buffer_length + char_len > buffer_max_len
	then call too_much_output;

	substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len);
	buffer_length = buffer_length + char_len;

real_part (3):					/*Kludge for real and DP.*/
output_return:
	call advance_element_p;
	return;

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

/*	Internal procedure to format free format real and dp numbers in ansi66 mode. */
ansi66_format:
     proc (single_precision, binary_no_ptr, no_string);

	dcl     single_precision	 bit (1);
	dcl     binary_no_ptr	 pointer;
	dcl     no_string		 char (26);

	dcl     (first_digit, no_of_digits, trailing_zeros, precision)
				 fixed bin;
	dcl     exponent		 pic "s999";
	dcl     exp_char		 char (1);
	dcl     dec_num		 float decimal (18);

/* WARNING the following structure is based upon the internal representation of ext float decimal data. */
	dcl     1 decimal_number	 structure aligned based (addr (dec_num)),
		2 sign		 char (1) unaligned,
		2 digits		 char (precision) unaligned,
		2 exp		 fixed bin (8) unaligned;

	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	if single_precision
	then do;
		precision = 8;
		exp_char = "E";
	     end;
	else do;
		precision = 18;
		bin_type = bin_type + 1;
		exp_char = "D";
	     end;
	call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type),
	     binary_prec (bin_type));
	first_digit = verify (decimal_number.digits, "0");
	if first_digit = 0				/* special case if number is zero */
	then do;
		first_digit = precision;
		exponent = 0;
	     end;
	else exponent = decimal_number.exp + (precision - (first_digit - 1));
	no_of_digits = precision - first_digit + 1;
	trailing_zeros = precision - no_of_digits;
	if decimal_number.sign = "+"
	then decimal_number.sign = " ";		/* suppress leading "+" sign. */

	substr (no_string, 1, 2) = "  ";
	substr (no_string, 3, 2) = decimal_number.sign || ".";
	substr (no_string, 5, precision) =
	     substr (decimal_number.digits, first_digit, no_of_digits) || copy ("0", trailing_zeros);
	if abs (exponent) > 99			/* drop the "E" */
	then substr (no_string, precision + 5, 4) = exponent;
	else substr (no_string, precision + 5, 4) = exp_char || substr (exponent, 1, 1) || substr (exponent, 3, 2);
     end ansi66_format;
     end ansi66_output;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */

/*	Internal procedure to output values in 'ansi77' mode. */

ansi77_output:
     proc;

	dcl     more_pieces		 bit,
	        num_sig_chars	 fixed bin,
	        piece_idx		 fixed bin,
	        piece_len		 fixed bin,
	        piece_max_len	 fixed bin;

	dcl     single_precision	 bit (1) int static options (constant) init ("1"b);
	dcl     double_precision	 bit (1) int static options (constant) init ("0"b);
	dcl     number_string	 char (30);
	dcl     number_length	 fixed bin;

	go to output_format (data_type);

output_format (1):					/* Integers. */
	int_pic = fio_ps.element_p -> integer;
	piece_idx = verify (int_pic, " ");		/*  Find first nonblank char.  */
	piece_len = length (int_pic) - piece_idx + 1;	/*  Find length of value.  */
	if buffer_length + piece_len > buffer_max_len
	then call too_much_output;
	substr (rest_of_output, 1, piece_len) = substr (int_pic, piece_idx, piece_len);
	buffer_length = buffer_length + piece_len;
	go to output_return;

output_format (2):					/* Single precision real. */
	j = 3;

convert_real_value:
	call ansi77_format (single_precision, fio_ps.element_p, number_string, number_length);
	if buffer_length + number_length > buffer_max_len
	then call too_much_output;
	substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length);
	buffer_length = buffer_length + number_length;
	go to real_part (j);

output_format (3):					/* Double precision real. */
	call ansi77_format (double_precision, fio_ps.element_p, number_string, number_length);
	if buffer_length + number_length > buffer_max_len
	then call too_much_output;
	substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length);
	buffer_length = buffer_length + number_length;
	go to output_return;

output_format (4):					/* Complex. */
	j = 1;
	if buffer_length >= buffer_max_len
	then call too_much_output;

	substr (rest_of_output, 1, 1) = "(";
	buffer_length = buffer_length + 1;

	go to convert_real_value;

real_part (1):					/* Append comma after real part for namelist. */
	if buffer_length >= buffer_max_len
	then call too_much_output;
	substr (rest_of_output, 1, 1) = ",";
	buffer_length = buffer_length + 1;
	fio_ps.element_p = addrel (fio_ps.element_p, 1);	/* Point to imaginary part.*/
	j = j + 1;				/*Next set of functions.*/
	go to convert_real_value;

real_part (2):					/*Right paren for namelist.*/
	if buffer_length >= buffer_max_len
	then call too_much_output;
	substr (rest_of_output, 1, 1) = ")";
	buffer_length = buffer_length + 1;
	fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */
	go to output_return;

output_format (5):					/* Logical */
	if buffer_length >= buffer_max_len
	then call too_much_output;

	if fio_ps.element_p -> logical
	then substr (rest_of_output, 1, 1) = "T";
	else substr (rest_of_output, 1, 1) = "F";
	buffer_length = buffer_length + 1;
	go to output_return;

output_format (6):					/* Character */
	if namelist
	then do;					/*  Store quoted character value in buffer.  */
		if buffer_length >= buffer_max_len
		then call too_much_output;
		substr (rest_of_output, 1, 1) = "'";
		buffer_length = buffer_length + 1;
		num_sig_chars = length (rtrim (substr (fio_ps.element_p -> chars, 1, char_len)));
		piece_idx = 1;
		more_pieces = TRUE;
		do while (more_pieces);
		     piece_max_len = num_sig_chars - piece_idx + 1;
		     piece_len = index (substr (fio_ps.element_p -> chars, piece_idx, piece_max_len), "'");
		     if piece_len = 0
		     then do;
			     piece_len = piece_max_len;
			     more_pieces = FALSE;
			end;
		     if buffer_length + piece_len + 1 > buffer_max_len
		     then call too_much_output;
		     substr (rest_of_output, 1, piece_len) = substr (fio_ps.element_p -> chars, piece_idx, piece_len);
		     substr (rest_of_output, piece_len + 1, 1) = "'";
		     buffer_length = buffer_length + piece_len + 1;
		     piece_idx = piece_idx + piece_len;
		end;
	     end;
	else do;					/*  Store raw character value in buffer.  */
		if buffer_length + char_len > buffer_max_len
		then call too_much_output;

		substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len);
		buffer_length = buffer_length + char_len;
	     end;

real_part (3):					/*Kludge for real and DP.*/
output_return:
	call advance_element_p;

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

/*	Internal procedure to format free format real and dp numbers in ansi77 mode. */
ansi77_format:
     proc (single_precision, binary_no_ptr, no_string, no_length);

	dcl     single_precision	 bit (1);
	dcl     binary_no_ptr	 ptr;
	dcl     no_string		 char (30);
	dcl     no_length		 fixed bin;

	dcl     1 output_number	 aligned structure based (addr (no_string)),
		2 pad		 char (no_length) unaligned,
		2 rest_of_number	 char (30) unaligned;
	dcl     (precision, first_digit, no_of_digits, no_of_zeros, dpt, chars_in_exp)
				 fixed bin;
	dcl     exponent		 pic "s999";
	dcl     dec_num		 float decimal (18);

/* WARNING the following structure is based upon the internal representation of ext float decimal data */
	dcl     1 decimal_number	 structure aligned based (addr (dec_num)),
		2 sign		 char (1) unaligned,
		2 digits		 char (precision) unaligned,
		2 exp		 fixed bin (8) unaligned;

	no_length = 0;
	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	if ^single_precision
	then do;
		precision = 18;
		bin_type = bin_type + 1;
	     end;
	else if fio_ps.job_bits.hfp
	then precision = 7;				/* hex real numbers have only 7 dec digits */
	else precision = 8;

	call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type),
	     binary_prec (bin_type));
	first_digit = verify (decimal_number.digits, "0");
	if first_digit = 0				/* special case if the number is zero */
	then do;
		first_digit = precision;
		no_of_digits = 1;
		exponent = 0;
	     end;
	else do;
		no_of_digits = length (rtrim (substr (decimal_number.digits, first_digit), "0"));
		exponent = decimal_number.exp + (precision - first_digit);
		if decimal_number.sign = "-"
		then do;
			substr (rest_of_number, 1, 1) = "-";
			no_length = no_length + 1;
		     end;
	     end;
	if exponent < -4 | exponent >= precision
	then do;					/* E format */
		if abs (exponent) < 100
		then chars_in_exp = 4;
		else chars_in_exp = 5;
		if no_of_digits = 1
		then dpt = 2;			/* if no digits after the decimal point, we need */
		else dpt = 1;			/* a trailing zero. */
		substr (rest_of_number, 1, 2) = substr (decimal_number.digits, first_digit, 1) || ".";
		if dpt = 2
		then substr (rest_of_number, 3, 1) = "0";
		else substr (rest_of_number, 3, no_of_digits - 1) =
			substr (decimal_number.digits, first_digit + 1, no_of_digits - 1);
		if chars_in_exp = 4
		then substr (rest_of_number, no_of_digits + dpt + 1, 4) =
			"E" || substr (exponent, 1, 1) || substr (exponent, 3, 2);
		else substr (rest_of_number, no_of_digits + dpt + 1, 5) = "E" || exponent;
		no_length = no_length + no_of_digits + dpt + chars_in_exp;
	     end;
	else do;					/* F format */
		if exponent < 0
		then do;				/* leading zeros needed */
			no_of_zeros = abs (exponent) - 1;
			substr (rest_of_number, 1, no_of_zeros + 2) = "0." || copy ("0", no_of_zeros);
			substr (rest_of_number, no_of_zeros + 3, no_of_digits) =
			     substr (decimal_number.digits, first_digit, no_of_digits);
			no_length = no_length + no_of_digits + no_of_zeros + 2;

		     end;
		else if exponent >= (no_of_digits - 1)
		then do;				/* trailing zeros may be needed */
			no_of_zeros = exponent - no_of_digits + 1;
			substr (rest_of_number, 1, no_of_digits) =
			     substr (decimal_number.digits, first_digit, no_of_digits);
			substr (rest_of_number, no_of_digits + 1, no_of_zeros + 2) =
			     copy ("0", no_of_zeros) || ".0";
			no_length = no_length + no_of_zeros + no_of_digits + 2;
		     end;
		else do;				/* decimal inside digits */
			dpt = exponent + 1;
			substr (rest_of_number, 1, dpt + 1) =
			     substr (decimal_number.digits, first_digit, dpt) || ".";
			substr (rest_of_number, dpt + 2, no_of_digits - dpt) =
			     substr (decimal_number.digits, first_digit + dpt, no_of_digits - dpt);
			no_length = no_length + no_of_digits + 1;
		     end;
	     end;
     end ansi77_format;
     end ansi77_output;


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

/* Internal procedure to input a line from the file system. */

buffer_read:
     proc;

	call read_a_record ();
	buffer_index = 0;
	if have_runtime_format
	then if skip_line_numbers
	     then call strip_line_no ();

     end buffer_read;


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

get_field:
     proc;					/* Finds first non-blank of field or the comma */

	i = 0;					/* get us into the loop */
	do while (i = 0);

	     do while (buffer_index >= buffer_length);	/* get non blank line */
		call buffer_read;
	     end;

	     i = verify (rest_of_record, white_space);

	     if i = 0
	     then call buffer_read;			/* rest of line is white; get another */
	end;

	buffer_index = buffer_index + i - 1;

	ch = substr (rest_of_record, 1, 1);

     end get_field;


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

check_end:
     proc;					/* insure field ended neatly */

	dcl     ii		 fixed bin;

	legal_end = "1"b;
	comma_encountered = "0"b;

	if buffer_index >= buffer_length
	then return;

	ii = verify (rest_of_record, white_space) - 1;
	if ii < 0					/* rest of the line is white */
	then do;
		buffer_index = buffer_length;
		return;
	     end;
	buffer_index = buffer_index + ii;		/* skip over white space */

	ch = substr (rest_of_record, 1, 1);

	if ch = ","
	then do;
		comma_encountered = "1"b;
		buffer_index = buffer_index + 1;
		return;
	     end;

	if namelist
	then if index (headers, ch) ^= 0
	     then return;
	     else ;
	else if ch = ";" | ch = "/"
	then return;

	if ii = 0
	then legal_end = "0"b;			/* messy ending only if no white space */

     end check_end;


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

/*	Internal procedure to handle runtime symbols. */
decode_runtime:
     proc;

	dcl     VLA_based		 bit (4) static options (constant) init ("1010"b);

/* Get symbol name. */
	name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name);
	name_ln = fixed (name_pt -> acc.name_size, 9);

/* Get symbol location. Note, pointer may not be to first element because of subs_pt. */
	fio_ps.element_p = stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null, subs_pt);

/* Get number of dimensions and pointer to end of variable's storage. */
	dims = fixed (symbol_pt -> runtime_symbol.ndims, 6);
	if dims > 0
	then do;
		do j = 1 to dims;
		     subscript_array (j) =
			stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (j).upper, block_pt, sp,
			link_pt, text_pt, null, my_code);
		     if my_code ^= 0
		     then go to bound_error;
		end;

		end_pt =
		     stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null,
		     addr (subscript_array));
	     end;
	else end_pt = fio_ps.element_p;

/* Get data type. */
	j = fixed (symbol_pt -> runtime_symbol.type, 6);
	if j <= 0 | j > hbound (runtime_table, 1)
	then go to unknown_type;
	data_type = runtime_table (j);
	if data_type = 0
	then
unknown_type:
	     call print_error (fortran_io_error_$namelist_error, me, "Invalid data type ^d for ^a.", j,
		name_pt -> acc.name_string);

/* Get character length, word length, and number of elements. */
	if data_type = character_type
	then char_len = symbol_pt -> runtime_symbol.size;
	else if data_type = double_type | data_type = complex_type
	then char_len = CPDW;
	else char_len = CPW;

/* for ansi66 character arrays are padded out, round up to the nearest whole 
   word, otherwise the chars_per_item  is the char_len */

	if data_type = character_type & ^fio_ps.ansi_77
	then chars_per_item = char_len - mod (char_len, -CPW);
	else chars_per_item = char_len;

/*  Check if the symbol is a VLA and calculate 'element_count' accordingly.  */
	if symbol_pt -> runtime_symbol.class = VLA_based
	then do;
		fio_ps.element_desc.VLA = TRUE;
		element_count =
		     divide ((fixed (baseno (end_pt)) - fixed (baseno (fio_ps.element_p))) * 4
		     * pl1_operators_$VLA_words_per_seg_ + char_pos (end_pt) - char_pos (fio_ps.element_p),
		     chars_per_item, 24, 0) + 1;
	     end;
	else do;
		fio_ps.element_desc.VLA = FALSE;
		element_count = divide (char_pos (end_pt) - char_pos (fio_ps.element_p), chars_per_item, 24, 0) + 1;
	     end;
     end decode_runtime;


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

/*	Procedure to store a null value. */
store_null:
     proc;

	if fio_ps.ansi_77
	then go to null_bump;			/* Do nothing */

	go to make_null (data_type);

make_null (1):
	fio_ps.element_p -> integer = 0;
	go to null_bump;

make_null (4):
	fio_ps.element_p -> complex_value.imag_part = 0.0;

make_null (2):
	fio_ps.element_p -> real = 0.0;
	go to null_bump;

make_null (3):
	fio_ps.element_p -> based_dp = 0.0;
	go to null_bump;

make_null (5):
	fio_ps.element_p -> logical = "0"b;
	go to null_bump;

make_null (6):
	substr (fio_ps.element_p -> chars, 1, char_len) = SP;

null_bump:
	call advance_element_p;
     end store_null;


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

/* Procedure to store constant into variable, depending on data types. */
store:
     proc;
	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	go to validate_store (data_type * 6 + constant_type - 7);

validate_store (0):					/* integer - integer */
validate_store (7):					/* real - real */
validate_store (28):				/* logical - logical */
	fio_ps.element_p -> words (1) = constant_ptr -> words (1);
						/* copy without conversion */
	goto store_bump;

validate_store (14):				/* double precision - double precision */
validate_store (21):				/* complex - complex */
	fio_ps.element_p -> based_bits = constant_ptr -> based_bits;
						/* copy without conversion */
	go to store_bump;

validate_store (1):					/* integer - real */
	call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type),
	     binary_prec (bin_type));
	go to store_bump;

validate_store (2):					/* integer - double precision */
	bin_type = bin_type + 1;			/* double precision binary type */
	call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type),
	     binary_prec (bin_type));
	go to store_bump;

validate_store (3):					/* integer - complex */
validate_store (9):					/* real - complex */
validate_store (15):				/* double precision - complex */
	call print_error (fortran_io_error_$syntax_error, me,
	     "Complex constants can only be used as input for complex variables.");

validate_store (4):					/* integer - logical */
validate_store (10):				/* real - logical */
validate_store (16):				/* double precision - logical */
validate_store (22):				/* complex - logical */
	call print_error (fortran_io_error_$syntax_error, me, "Numeric variables may not be assigned logical values.");

validate_store (5):					/* integer - character */
validate_store (11):				/* real - character */
validate_store (17):				/* double precision - character */
validate_store (23):				/* complex - character */
validate_store (35):				/* character - character */
	substr (fio_ps.element_p -> chars, 1, char_len) = substr (work_str, 1, str_len);
	go to store_bump;

validate_store (18):				/* complex - integer */
	fio_ps.element_p -> complex_value.imag_part = 0.0;

validate_store (6):					/* real - integer */
	call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr,
	     integer_dtype, integer_prec);
	go to store_bump;

validate_store (20):				/* complex - double precision */
	fio_ps.element_p -> complex_value.imag_part = 0.0;

validate_store (8):					/* real - double precision */
	call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr,
	     binary_type (bin_type + 1), binary_prec (bin_type + 1));
	go to store_bump;

validate_store (19):				/* complex - real */
	fio_ps.element_p -> complex_value.imag_part = 0.0;
	fio_ps.element_p -> real = constant_ptr -> real;
	go to store_bump;

validate_store (12):				/* double precision - integer */
	bin_type = bin_type + 1;
	call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr,
	     integer_dtype, integer_prec);
	go to store_bump;

validate_store (13):				/* double precision - real */
	bin_type = bin_type + 1;
	call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work),
	     ext_float_decimal, (max_float));
	go to store_bump;

validate_store (24):				/* logical - integer */
validate_store (25):				/* logical - real */
validate_store (26):				/* logical - double precision */
validate_store (27):				/* logical - complex */
validate_store (29):				/* logical - character */
	call print_error (fortran_io_error_$syntax_error, me, "Logical variables must be assigned logical values.");

validate_store (30):				/* character - integer */
validate_store (31):				/* character - real */
validate_store (32):				/* character - double precision */
validate_store (33):				/* character - complex */
validate_store (34):				/* character - logical */
	call print_error (fortran_io_error_$syntax_error, me, "Character variables must be assigned character values.");

store_bump:
	call advance_element_p;
     end store;


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

/* Procedure to input any type of number. */
input_float:
     proc;
	begin_index = buffer_index;
	legal_end = "0"b;
	constant_type = integer_type;
	dec_flt = 0.0;

	if substr (rest_of_record, 1, 1) = "+" | substr (rest_of_record, 1, 1) = "-"
	then do;
		number.sign = substr (rest_of_record, 1, 1);
		buffer_index = buffer_index + 1;
		if buffer_index = buffer_length
		then call syntax_error;
	     end;

	i = verify (rest_of_record, "0") - 1;
	if i ^= 0
	then do;
		if i < 0
		then do;
			buffer_index = buffer_length;
zero_field:
			constant_ptr -> integer = 0;
			constant_type = integer_type;
			return;
		     end;
		buffer_index = buffer_index + i;
		legal_end = "1"b;
	     end;

	prec = verify (rest_of_record, digits) - 1;
	if prec ^= 0
	then do;
		if prec < 0
		then prec = buffer_length - buffer_index;
		if prec > max_float
		then call conversion_error;
		number.digit = substr (rest_of_record, 1, prec);
		buffer_index = buffer_index + prec;
		if buffer_index = buffer_length
		then go to build_integer;
		legal_end = "1"b;
	     end;

	e = 0;
	dexp = 0;

	ch = substr (rest_of_record, 1, 1);
	if ch = "."
	then do;
		constant_type = real_type;
		buffer_index = buffer_index + 1;
		if buffer_index = buffer_length
		then if ^legal_end
		     then call syntax_error;
		     else go to build_binary;
		e = verify (rest_of_record, digits) - 1;
		if e ^= 0
		then do;
			if e < 0
			then e = buffer_length - buffer_index;
			if prec = 0
			then do;
				i = verify (substr (rest_of_record, 1, e), "0") - 1;
				if i < 0
				then i = e;
			     end;
			else i = 0;

			if prec + (e - i) > max_float
			then call conversion_error;
			if (e - i) > 0
			then substr (number.digit, prec + 1, e - i) = substr (rest_of_record, i + 1, e - i);
			prec = prec + (e - i);
			buffer_index = buffer_index + e;

			if buffer_index = buffer_length
			then go to build_binary;
			legal_end = "1"b;
		     end;
		ch = substr (rest_of_record, 1, 1);
	     end;

	if ^legal_end
	then call syntax_error;			/* Must have some digits. */

	if index (exps, ch) ^= 0
	then do;
		legal_end = "0"b;			/* Indicate need for exponent field. */
		constant_type = real_type;
		if index ("eE", ch) = 0
		then constant_type = double_type;
		buffer_index = buffer_index + 1;
		if buffer_index = buffer_length
		then call syntax_error;

		i = verify (rest_of_record, white_space);
		if i = 0
		then call syntax_error;
		buffer_index = buffer_index + i - 1;
		ch = substr (rest_of_record, 1, 1);
	     end;

	j = buffer_index;				/* Lets us remember the sign. */

	if index ("+-", ch) ^= 0
	then do;
		legal_end = "0"b;			/* Indicate need for exponent field. */
		if constant_type = integer_type
		then constant_type = real_type;
		buffer_index = buffer_index + 1;
		if buffer_index = buffer_length
		then call syntax_error;
	     end;

	if constant_type = integer_type
	then do;
build_integer:
		if prec = 0
		then go to zero_field;
		if prec > max_fixed
		then call conversion_error;
		substr (work_str, 1, prec + 1) = substr (work, 1, prec + 1);
		dec_int = 0;
		substr (work, 1, 1) = substr (work_str, 1, 1);
		substr (number.digit, max_fixed - prec + 1, prec) = substr (work_str, 2, prec);

		constant_ptr -> integer = convert (integer, dec_int);
		return;
	     end;

	if ^legal_end				/* Get an exponent field only if there was an "e" or sign. */
	then do;
		i = verify (rest_of_record, digits) - 1;
		if i < 0
		then i = buffer_length - buffer_index;
		if i = 0
		then call syntax_error;		/* Must have some digits. */

		dexp = convert (dexp, substr (io_buf, j + 1, i + buffer_index - j));
		buffer_index = buffer_index + i;
	     end;

build_binary:
	if prec = 0
	then go to zero_field;
	e = dexp - e + prec - max_float;
	if e > 255 | e < -256
	then call conversion_error;

	flt_dec.exp = e;

	if fio_ps.job_bits.hfp
	then bin_type = 3;
	else bin_type = 1;
	if constant_type = double_type
	then bin_type = bin_type + 1;
	call assign_round_ (constant_ptr, binary_type (bin_type), binary_prec (bin_type), addr (work),
	     ext_float_decimal, (max_float));

     end input_float;


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

input_complex:
     proc;

	buffer_index = buffer_index + 1;		/* skip "(" */

	call get_field;

	call input_piece_of_complex (c_temp (1), "0"b);

	if ^comma_encountered
	then call syntax_error;			/* comma must be used */

	call get_field;

	call input_piece_of_complex (c_temp (2), "1"b);

	if comma_encountered
	then call syntax_error;

	if substr (rest_of_record, 1, 1) ^= ")"
	then call syntax_error;
	buffer_index = buffer_index + 1;		/* Skip ")" */

	unspec (constant_ptr -> complex_value) = unspec (c_temp);

	constant_type = complex_type;
     end input_complex;



input_piece_of_complex:
     proc (x, paren_ok);

	dcl     x			 float bin (27);
	dcl     paren_ok		 bit (1) aligned;

	call input_float;				/* get integer or real */

	if constant_type = integer_type
	then do;
		if fio_ps.job_bits.hfp
		then bin_type = 3;
		else bin_type = 1;
		call assign_round_ (addr (x), binary_type (bin_type), binary_prec (bin_type), constant_ptr,
		     integer_dtype, integer_prec);
	     end;

	else if constant_type = real_type
	then x = constant_ptr -> real;

	else call print_error (fortran_io_error_$syntax_error, me,
		"Double precision constant cannot be used as input for complex variables.");

	call check_end;
	if ^(legal_end | (paren_ok & ch = ")"))
	then call bad_char;
     end input_piece_of_complex;


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

/* Procedure to input a logical constant. */
input_logical:
     proc;

	dcl     delims		 char (4) static options (constant) initial (" 	,/");
						/* space tab , / */


	constant_type = logical_type;
	if substr (rest_of_record, 1, 1) = "."
	then if length (rest_of_record) < 2
	     then call syntax_error;			/*  Logical value must follow period.  */
	     else ch = substr (rest_of_record, 2, 1);	/*  2nd char determines logical value.  */
	else ch = substr (rest_of_record, 1, 1);	/*  1st char determines logical value.  */
	if ch = "t" | ch = "T"
	then constant_ptr -> logical = TRUE;
	else if ch = "f" | ch = "F"
	then constant_ptr -> logical = FALSE;
	else call syntax_error;

	j = search (rest_of_record, delims) - 1;
	if j < 0
	then j = length (rest_of_record);
	buffer_index = buffer_index + j;

     end input_logical;


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

/* Procedure to input quoted character strings. */
input_charstr:
     proc;
	str_len = 0;
	buffer_index = buffer_index + 1;		/* Skip initial delimiter */

	do while ("1"b);
	     i = index (rest_of_record, ch) - 1;

/* If data is not all on this record, then do multiple buffer reads to find
   terminator. */

	     if i < 0
	     then do;
		     call build_string (length (rest_of_record));
		     call buffer_read;
		end;
	     else do;
		     call build_string (i);
		     buffer_index = buffer_index + 1;
		     if buffer_index >= buffer_length
		     then return;
		     if substr (rest_of_record, 1, 1) ^= ch
		     then return;
		     call build_string (1);
		end;
	end;
     end input_charstr;


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

build_string:
     proc (len1);
	dcl     (len1, len2)	 fixed bin (18);

	len2 = len1;
	if str_len + len1 > 256
	then do;
		call com_err_ (0, me, "Character string truncated to 256 characters.");
		len2 = 256 - str_len;
	     end;
	if len2 > 0
	then substr (work_str, str_len + 1, len2) =
		substr (rest_of_record, 1, min (len2, buffer_length - buffer_index));
	str_len = str_len + len2;
	buffer_index = buffer_index + len1;
	constant_type = character_type;

     end build_string;

     end namelist_io;

set_size_and_count:
     procedure (element_size, element_count, pointer_bump);

/* Returns size and count information about the data being transmitted.
   element_size is the number of interesting bytes in one element,
   element_count is the number of elements, and pointer_bump is the number
   of bytes of storage allocated to one element. */

	declare data_type		 fixed bin,
	        element_count	 fixed bin (24);
	declare (element_size, pointer_bump)
				 fixed binary (21);



	data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0));
	goto set_size (data_type);

set_size (1):					/* integer */
set_size (2):					/* real */
set_size (5):					/* logical */
	pointer_bump, element_size = CPW;
	goto set_count;

set_size (3):					/* double */
set_size (4):					/* complex */
	pointer_bump, element_size = CPDW;
	goto set_count;

set_size (6):					/* character */
	if fio_ps.ansi_77
	then pointer_bump, element_size = fio_ps.length;
	else do;
		element_size = fio_ps.length;
		pointer_bump = divide (fio_ps.length + CPW - 1, CPW, 17, 0) * CPW;
	     end;
	go to set_count;


/* fio_ps.element_count is the total number of WORDS in the array, except for
   character arrays in ansi_77 format, where it is the total number of BYTES
   in the array.  We map this number into the actual number of ELEMENTS to be
   transmitted. */

set_count:
	if fio_ps.array_ref & fio_ps.element_count > 0
	then do;
		if data_type = 6			/* character array */
		then if fio_ps.ansi_77
		     then element_count = divide (fio_ps.element_count, pointer_bump, 17, 0);
		     else element_count = divide (fio_ps.element_count * CPW, pointer_bump, 17, 0);

		else if fio_ps.double | fio_ps.complex
		then element_count = divide (fio_ps.element_count, 2, 17, 0);

		else element_count = fio_ps.element_count;


	     end;

	else element_count = 1;

     end set_size_and_count;

char_pos:
     procedure (P_character_ptr) returns (fixed binary (21));
						/* Calculate the character position in a segment of a character pointer.
   Written 6-Nov-79 by M. N. Davidoff.
   Altered for use with fortran_io_ by MEP August 1980 */


	declare P_character_ptr	 pointer;		/* (Input) pointer to a character in a segment */

/* automatic */

	declare source_position	 fixed binary (21);
	declare source_ptr		 pointer;

/* based */

	declare character_array	 (4 * sys_info$max_seg_size) char (1) based (source_ptr);

/* program */

	source_ptr = baseptr (baseno (P_character_ptr));

/* Calculate the character position of the character pointer. */

	source_position = 4 * binary (rel (P_character_ptr), 18) + 1;
	do while (addr (character_array (source_position)) ^= P_character_ptr);
	     source_position = source_position + 1;
	end;

	return (source_position);
     end char_pos;

advance_element_p:
     proc;

/*  Advance 'fio_ps.element_p' by 'chars_per_item' characters. */

	dcl     error_table_$boundviol fixed bin (35) ext;

	dcl     01 element_p	 aligned based (addr (fio_ps.element_p)) like its_unsigned;

	dcl     01 segment		 aligned based (baseptr (element_p.segno)),
		02 pad		 bit (bits_before_element) unaligned,
		02 element	 bit (bits_in_element) unaligned;

	dcl     bits_before_element	 fixed bin (24),
	        bits_in_element	 fixed bin (24);

	bits_in_element = 9 * chars_per_item;
	bits_before_element = 36 * element_p.offset + element_p.bit_offset + bits_in_element;
	if fio_ps.element_desc.VLA
	then if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_
	     then do;				/*  Cross over to next VLA component.  */
		     bits_before_element = bits_before_element - 36 * pl1_operators_$VLA_words_per_seg_;
		     if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_
		     then call print_error (error_table_$boundviol);
		     element_p.segno = element_p.segno + 1;
		end;
	fio_ps.element_p = addr (element);
	return;
%include its;
     end advance_element_p;

     end fortran_io_;




		    fortran_io_error_.alm           11/05/86  1557.9r w 11/04/86  1038.6       51561



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

" Written:	June 1977, David Levin.

" Modified:
"		8 September 1977, David Levin - add not_scratch_file.
"		11 August 1977, David Levin - add cannot_reopen, not_blocked, wrong_mode.
"		26 Apr 82, HH - correct 'invalid_scale_factor' message.
"		19 Apr 82, HH - add 'read_after_eof' and 'write_after_eof'.
"			add descriptive comments and fix existing error text.
"                   15 July 83, MM - 406: change not_scratch_file to leave out the word 'created'.

	include	et_macros



	et	fortran_io_error_



"	Errors in access field such as: value too long, value all blank.
"
ec  access_field_error,accferr,
	(Error in access field.)
"
"	An attribute is specified that cannot be specified for a connected file.
"	Accompanying text identifies the attribute.
"
ec  already_connected,connectd,
	(This open attribute cannot be supplied if the file is already connected.)
"
"	An attribute is specified that cannot be specified for a file not opened by fortran.
"	Accompanying text identifies the attribute.
"
ec  already_opened,opened,
	(This open attribute cannot be supplied if the file is already opened.)
"
"	Errors such as: value too long, value all blank.
"
ec  attach_desc_field_error,attferr,
	(Error in the attach description field.)
ec  bad_char,bad_char,(Invalid or unexpected character in external data field.)
"
"	Not a sequential file or I/O module does not support rewind or backspace.
"
ec  blank_field_error,blnkferr,(Error in the blank field.)

ec  cannot_position,no_pos,
	(This file cannot be backspaced or rewound.)
"
"	Not open for input.
"
ec  cannot_read,no_read,
	(This file cannot be read.)
"
"	Attempt to reopen fails, probably because I/O switch does not support requested opening mode.
"	Possibly user does not have access to write.
"
ec  cannot_reopen,noreopen,
	(This file cannot be opened with the requested mode.)
ec  cannot_truncate,no_trunc,(This file opening does not permit file truncation.)
ec  cannot_write,no_write,(This file opening does not permit output operations.)
ec  close_attr_error,clse_err,(Error in the close statement attributes.)
ec  conversion_error,conv_err,(External data field cannot be converted.)
ec  dnumeric_file,dnumeric,(Double word binary files are limited to double precision data.)
ec  filename_field_error,flnmferr,(Error in the filename field.)
ec  fio_sys_error,fioerror,(FORTRAN I/O Error. Contact FORTRAN maintenance personnel.)
ec  form_field_error,formferr,(Error in the form field.)
ec  format_error,fmt_err,(Error in format specification.)
ec  format_is_infinite,infi_fmt,(Infinite loop in format. There is a list item but the format has no field descriptors.)
ec  formatted_file,fmt_file,(Formatted files are limited to formatted records.)
ec  incompatible_opening,inc_open,(The file opening is not compatible with the existing file.)
ec  internal_file_oflow,int_oflo,(An attempt has been made to access a record beyond the end of an internal file.)
ec  invalid_file0_attr,file0err,(Only prompt, defer, and carriage attributes are allowed for file 0.)
ec  invalid_file0_type,file0err,(Only the print or terminal file type can be specified for file 0.)
ec  invalid_for_file0,file0err,(This operation is not allowed for file 0.)
ec  invalid_max_recl,bad_recl,(Invalid value for the maximum record length.)
ec  invalid_scale_factor,badscale,(The scale factor for Dw.d and Ew.d edit descriptors must be between -d and d+2.)
ec  io_switch_field_error,ioswferr,(Error in the I/O switch field.)
ec  long_record,long_rec,(Maximum record length exceeded.)
ec  missing_header,no_nlhdr,(Namelist input must begin with a header.)
ec  mode_field_error,modeferr,(Error in the mode field.)
ec  must_be_empty,notempty,(File must be empty in order to set maximum record length.)
ec  namelist_error,nl_error,(Error in namelist I/O.)
"
"	Operation requires file to be blocked file.
"
ec  not_blocked,not_blk,
	(This file is not a blocked file.)
ec  not_direct,not_dir,(This file opening does not permit direct access I/O.)
ec  not_open,not_open,(File must be open before being used.)
ec  not_scratch_file,notscrch,(This file was not opened and attached by FORTRAN I/O.)
ec  not_sequential,not_seq,(This file opening does not permit sequential access I/O.)
ec  open_attr_conflict,openconf,(These two open attributes are mutually exclusive.)
ec  open_attr_incomplete,openinc,(The open attributes are incomplete.)
ec  parens_too_deep,manyparn,(Maximum format parenthesis level exceeded.)
ec  read_after_eof,eofread,(Attempt to read past EOF record.)
ec  short_record,shortrec,(Attempt to read more data than the record contains.)
ec  status_field_error,staferr,(Error in status field.)
ec  syntax_error,syntxerr,(Syntax error in the external data field.)
ec  unformatted_file,unf_file,(Unformatted files are limited to unformatted records.)
"
"	Probably an error with vfile_status_.
"
ec  unknown_filetype,unknfile,
	(The file type of the external file is not recognized.)
ec  write_after_eof,eofwrite,(Attempt to write past EOF record.)
"
"	I/O switch is not opened by FORTRAN I/O, however, it is necessary to reopen the I/O switch
"	in order to satisfy the mode attribute specified by the user.
"
ec  wrong_mode,bad_mode,
	(The I/O switch was not opened by FORTRAN and it does not support the requested mode.)


	end




		    fortran_pause_.pl1              12/27/84  0853.8rew 12/27/84  0838.7       19395



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

/* format: style3,^delnl,linecom */
fortran_pause_:
     procedure (string) options (support);

/* This procedure is called to perform the function of the Fortran PAUSE statement. */

/* Modification History:

83-05-16 HH - 117: Implement a pause by signalling 'fortran_pause' rather
	than printing a message and entering a new command level.
83-06-16 TO - Implement options (support) and only force signal catching if
	interactive.  Also add "PAUSE" to output string.
*/


dcl	string		char (*);

dcl	fast_related_data_$in_fast_or_dfast
			bit (1) aligned ext static;

dcl	INTERACTIVE	fixed bin (17) static options (constant) initial (1);

dcl	process_type	fixed bin (17);

dcl	ioa_		external entry options (variable),
	signal_		entry options (variable),
	user_info_$process_type
			entry (fixed bin (17));

dcl	length		builtin,
	null		builtin;

%include condition_info_header;

dcl	01 condition_info	aligned like condition_info_header;

	if fast_related_data_$in_fast_or_dfast
	then call ioa_ ("^/PAUSE ^a", string);
	else do;					/*  Signal 'fortran_pause' condition.  */
		condition_info.length = size (condition_info);
		condition_info.version = 1;
		unspec (condition_info.action_flags) = ""b;

/* If we are not interactive then permit a default restart to let an absentee
   continue. */
		call user_info_$process_type (process_type);
		if process_type ^= INTERACTIVE
		then condition_info.default_restart = "1"b;

		condition_info.info_string = "PAUSE " ||
		     substr (string, 1, min (length (string), maxlength (condition_info.info_string)));
		condition_info.status_code = 0;
		call signal_ ("fortran_pause", null, addr (condition_info));
	     end;
     end fortran_pause_;




		    fortran_stop_.pl1               12/27/84  0853.8rew 12/27/84  0838.7       14886



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

/* format: style3,^delnl,linecom */
fortran_stop_:
     procedure (str);

/*	This version of fortran_stop_ is intended to replace the installed
	and contains logic agreed upon by members of the fortran user community.

	August 2, 1972
Modified:
	09 Jul 79, CRD - to add fortran_end entry.
	07 Aug 78, PES - to interface to run unit facility.
	08 Jun 77, DSL - New fortran I/O system interface.
	26 Feb 76, GDC - to interface with fast subsystem.
	12 Sep 73, DSL - to interface with new I/O system.
*/

dcl
	str		char (*);
dcl	ioa_		entry options (variable),
	fortran_io_$stop	entry;
dcl	stop_run		external entry;
dcl	(string, addr)	builtin;
dcl	illegal_return	condition;

dcl	fast_related_data_$in_fast_or_dfast
			bit (1) aligned ext static;

dcl	fast_related_data_$terminate_run
			entry variable ext static;

	call ioa_ ("^/STOP ^a", str);

	go to common;

exit:
     entry;
	call ioa_ ("^/STOP via call exit");
	go to common;


fortran_end:
     entry;


common:
	call fortran_io_$stop;

	if fast_related_data_$in_fast_or_dfast
	then call fast_related_data_$terminate_run ();
	else do;
		call stop_run;
		do while ("1"b);
		     signal illegal_return;
		end;
	     end;

     end;




		    fortran_storage_.pl1            11/20/86  1412.9rew 11/20/86  1142.5      151110



/****^  ******************************************
        *                                        *
        * Copyright, (C) Honeywell Limited, 1983 *
        *                                        *
        ****************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-09-18,DGHowe), approve(86-09-18,MCR7420),
     audit(86-09-19,Schroth), install(86-11-20,MR12.0-1222):
     changed the calling sequence of list_init_.
                                                   END HISTORY COMMENTS */


/* format: style3,^delnl,linecom */
fortran_storage_:
     proc (sp, lp, tp) options (support);
create:
     entry (sp, lp, tp);


/* This driver receives control from pl1_operators_ when a call is received
   from a fortran program to create and/or initialize external data storage,
   such as Large and Very Large Arrays.

   Entry Conditions:

   sp          This is the stack pointer to the stack frame of the fortran
               program making the request.
   lp          This is the linkage pointer to the linkage section of the
               program making the request.
   tp          This is a pointer to the text section parameter word.  This
               word is in the format:

               vfd 18/create_relative_offset,18/initialize_relative_offset

               These pointers are offsets from the base of the segment of tp.

*/

/* Create 82-09-07 by T. Oke (UNCA) */

/* Modification History:

   Modified: 27 June 1986, DH & BW - Use new interface to list_init_ and
	set_external_variable_.
   Modified: 16 June 1983, TO- Use condition_info_header, have
	options (support).
   Modified: 29 May 1983, MW - To call sub_err_ if find perprocess static
   Modified: 16 February 1983, TO- Set stack_header.have_static_vlas for use
	of run_.
   Modified: 15 February 1983, TO- Set linkage_header_flags.static_vlas for
	use of run_.
   Modified: 26 January 1983, HH - Replaced 'fill_VLA_addressors' routine.
   Modified: 18 January 1983, TO - Match with CISL implementation of link
	snapping to VLA COMMON from the linker.
*/



dcl	lp		ptr;			/* Pointer to base of linkage section */
dcl	sp		ptr;			/* Pointer to stack frame of caller */
dcl	tp		ptr;			/* Pointer to parameter word */

dcl	(alp, asp, atp)	ptr;			/* actual running pointers */

dcl	1 parm		based (tp),
	  2 create_relp	bit (18) unaligned,		/* relative offset from tp to creation data */
	  2 init_relp	bit (18) unaligned;		/* relative offfset from tp to initialization data */

%include fortran_storage;

/* Based Variables */

dcl	based_ptr		ptr based;
dcl	LA_base_addressor	ptr based (base_addressor_ptr);
dcl	VLA_base_addressor	ptr unaligned based (base_addressor_ptr);

/* Automatic Storage */

dcl	base_addressor_ptr	ptr;
dcl	code		fixed bin (35);
dcl	cp		ptr;			/* pointer to create entry */
dcl	defp		ptr;			/* pointer to definition section */
dcl	found_sw		bit (1) aligned;		/* external was found */
dcl	length		fixed bin (24);		/* number of words needed */
dcl	linkp		ptr;			/* pointer to link */
dcl	looping		bit (1);			/* true while doing lists */
dcl	namep		ptr;			/* pointer to block name from link */
dcl	num_segs_needed	fixed bin;		/* number of segments needed */
dcl	storage_ptr	ptr;
dcl	textp		ptr;			/* pointer to text section */
dcl	type_ptr		ptr;			/* pointer to type_pair */
dcl	variablep		ptr;			/* pointer to variable_node */

dcl	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) external;

dcl	fortran_storage_manager_$alloc
			entry (fixed bin, ptr, ptr);
dcl	list_init_	entry (ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35));
dcl	set_ext_variable_	entry (char (*), ptr, ptr, bit (1) aligned, ptr, fixed bin (35));
dcl	sub_err_		entry options (variable);


dcl	(addr, addrel, baseno, currentsize, divide, fixed, null, ptr, rel, rtrim, stackbaseptr, string, substr, unspec)
			builtin;

	textp = ptr (tp, "000000"b3);			/* get pointer to text section */
	atp = tp;
	alp = lp;
	asp = sp;
	code = 0;



/* process Storage creation. */

	looping = "1"b;
	if parm.create_relp ^= "777777"b3		/* list exists */
	then do cp = ptr (atp, parm.create_relp) repeat ptr (atp, unspec (cp -> create_entry.next)) while (looping);

		length = cp -> create_entry.length;

/* pl1_operators_$VLA_words_per_seg_ determines the actual addressing which will occur in
   this execution.  It is used to determine the number of segments required. */

		num_segs_needed =
		     divide (length + pl1_operators_$VLA_words_per_seg_ - 1, pl1_operators_$VLA_words_per_seg_, 17);

		if cp -> create_entry.flags.auto
		then do;				/* Automatic storage */
			call fortran_storage_manager_$alloc (num_segs_needed, asp, storage_ptr);
			if cp -> create_entry.init
			then call list_init_ (storage_ptr,
				addrel (cp, currentsize (cp -> create_entry)),
				(cp -> create_entry.length),
				stackbaseptr (), null (), code);
			base_addressor_ptr = addrel (asp, cp -> create_entry.location);
			if cp -> create_entry.flags.LA
			then LA_base_addressor = storage_ptr;
			else call fill_VLA_addressors;
		     end;

		else if cp -> create_entry.flags.static
		then do;				/* Static if not init */
			base_addressor_ptr = addrel (alp, cp -> create_entry.location);
			if cp -> create_entry.flags.LA
			then do;
				if LA_base_addressor = null ()
				then do;
					if alp -> linkage_header_flags.perprocess_static
					then call signal_sub_error;
					call fortran_storage_manager_$alloc (num_segs_needed, alp, storage_ptr);
					if cp -> create_entry.init
					then call list_init_ (storage_ptr,
						addrel (cp, currentsize (cp -> create_entry)),
						(cp -> create_entry.length), stackbaseptr (),
						null (), code);
					LA_base_addressor = storage_ptr;
				     end;
			     end;
			else do;
				if VLA_base_addressor = null ()
				then do;
					if alp -> linkage_header_flags.perprocess_static
					then call signal_sub_error;
					call fortran_storage_manager_$alloc (num_segs_needed, alp, storage_ptr);
					if cp -> create_entry.init
					then call list_init_ (storage_ptr,
						addrel (cp, currentsize (cp -> create_entry)),
						(cp -> create_entry.length), stackbaseptr (),
						null (), code);
					call fill_VLA_addressors;
				     end;
			     end;

/* Set stack_header.have_statis_vlas and linkage_header_flags.static_vlas to
   inform run_ that there will be external segments to preserve. */

			ptr (asp, "0"b) -> stack_header.have_static_vlas = "1"b;
			alp -> linkage_header_flags.static_vlas = "1"b;

		     end;

		else if cp -> create_entry.flags.common
		then do;

/* Find pointer to addressor (base_addressor_ptr -> VLA_base_addressor), and pointer to true full
   link (linkp -> link). */

			base_addressor_ptr = addrel (alp, cp -> create_entry.location);
			linkp = addrel (alp, cp -> create_entry.common_link);

/* If link is unsnapped, or disagrees with 'VLA_base_addressor' then update 'VLA_base_addressor' */

			if linkp -> link.ft2 ^= "46"b3/* snapped */
			then if linkp -> based_ptr ^= VLA_base_addressor
						/* wrong VLA_base_addressor */
			     then do;		/* take link */
				     storage_ptr = linkp -> based_ptr;
				     call fill_VLA_addressors;
				end;
			     else ;

			else do;			/* snap link and fill pointers */
re_try_snap:
				call snap_link (code);
				if code ^= 0
				then do;
					call signal_fortran_storage_error (code,
					     " COMMON block " || cp -> create_entry.block_name);
					goto re_try_snap;
				     end;
				call fill_VLA_addressors;
			     end;
		     end;

		if code ^= 0
		then do;
			call sub_err_ (code, "fortran_storage_",
			     ACTION_CANT_RESTART, null, 0,
			     "An error has occurred while initializing ^a.",
			     cp -> create_entry.block_name);
			return;
		     end;
		if cp -> create_entry.next = 0
		then looping = "0"b;
	     end;
	return;

/* Resolve a linkage error for VLA COMMON. */

resolve_VLA_COMMON_link:
     entry (a_link_ptr, a_def_ptr, a_type_ptr, a_code);


dcl	a_code		fixed bin (35);		/* error code */
dcl	a_def_ptr		ptr;			/* definition ptr, also text section ptr */
dcl	a_link_ptr	ptr;			/* pointer to link  to snap */
dcl	a_type_ptr	ptr;			/* pointer to type_word */


/* When the linker finds a link to VLA COMMON 'link_trap_caller_' will call
   us to resolve the link and initialize it.  We in turn simply call our
   local 'snap_link' procedure. */

	linkp = a_link_ptr;

/* setup for snapping the link and creation of the COMMON.

   text pointer is taken from a_def_ptr, which should be into the text segment
   and therefore usable in our case. */

	atp = ptr (a_def_ptr, "0"b);
	alp = addrel (linkp, linkp -> link.head_ptr);
	call snap_link (a_code);
	return;

fill_VLA_addressors:
     proc;

/*  Function:  to calculate and store the addressors of the base and various */
/*     offsets of a VLA.  The logical address of the VLA is stored in the    */
/*     base addressor and the packed pointer to the offset is stored in each */
/*     offset addressor.  (The logical address of a storage location is just */
/*     its segment number times the maximum length in words of its segment   */
/*     plus its word offset in the segment.  For 256K segments, it is just   */
/*     the packed pointer to the location, considered as an integer.)        */

/*  Global Arguments:                                                        */
/*                                                                           */
/*  base_addressor_ptr  (Input)                                              */
/*     is the address where the value of the base addressor of the VLA is to */
/*     be stored.  The addressors of any offsets into the VLA are stored in  */
/*     successive locations.                                                 */
/*                                                                           */
/*  cp  (Input)                                                              */
/*     is the address of the 'creation_entry' structure which specifies any  */
/*     offsets into the VLA and whether the calling program can operate with */
/*     other than 256K segments.                                             */
/*                                                                           */
/*  storage_ptr  (Input)                                                     */
/*     is the address of the storage that has been assigned to the VLA.      */

dcl	error_table_$resource_unavailable
			fixed bin (35) ext;

dcl	01 VLA_addressors	aligned based (base_addressor_ptr),
	  02 addressor_of_base
			fixed bin (30),
	  02 addressor_of_offset
			(offset_cnt) fixed bin (30);

dcl	offset		(offset_cnt) fixed bin (24) based (offset_ptr);

dcl	i		fixed bin,
	logical_address_of_base
			fixed bin (30),
	logical_address_of_offset
			fixed bin (30),
	offset_cnt	fixed bin,
	offset_ptr	ptr,
	VLA_base_ptr	ptr unaligned;

/*  Copy various input values to local storage so we can get faster access.  */

	offset_cnt = cp -> create_entry.pointer_count;
	if offset_cnt > 0
	then offset_ptr = addr (cp -> create_entry.pointer_offsets);
	VLA_base_ptr = storage_ptr;

/*  If the 256K flag is set, we must ensure that storage is being allocated  */
/*  in 256K segments, since otherwise the calling program will not operate   */
/*  correctly.                                                               */

	if cp -> create_entry.K256
	then do while (pl1_operators_$VLA_words_per_seg_ ^= 262144);
		call signal_fortran_storage_error (error_table_$resource_unavailable,
		     "Program requires storage to be allocated in 256K segments.");
	     end;

/*  Fill in the addressors of the base and offsets into the VLA.  If storage */
/*  is allocated in 256K segments, logical addresses are also packed ptrs    */
/*  and so we can use simpler code which runs much faster.                   */

	if pl1_operators_$VLA_words_per_seg_ = 262144
	then do;					/*  Logical addresses are also packed pointers.  */
		unspec (logical_address_of_base) = unspec (VLA_base_ptr);
		VLA_addressors.addressor_of_base = logical_address_of_base;
		do i = 1 to offset_cnt;
		     VLA_addressors.addressor_of_offset (i) = logical_address_of_base + offset (i);
		end;
	     end;
	else do;					/*  Logical addresses are different than packed pointers.  */
		logical_address_of_base =
		     fixed (baseno (VLA_base_ptr), 12) * pl1_operators_$VLA_words_per_seg_
		     + fixed (rel (VLA_base_ptr), 18);
		VLA_addressors.addressor_of_base = logical_address_of_base;
		do i = 1 to offset_cnt;
		     logical_address_of_offset = logical_address_of_base + offset (i);
		     VLA_addressors.addressor_of_offset (i) =
			logical_address_of_offset
			+ fixed (262144 - pl1_operators_$VLA_words_per_seg_, 18)
			* divide (logical_address_of_offset, pl1_operators_$VLA_words_per_seg_, 12);
		end;
	     end;
     end fill_VLA_addressors;

signal_fortran_storage_error:
     proc (status, details);

/*  Function:  to signal the restartable condition 'fortran_storage_error'.  */

/*  Arguments:                                                               */
/*                                                                           */
/*  status  (Input)                                                          */
/*     is a standard system status code describing why the condition is      */
/*     being signalled.                                                      */
/*                                                                           */
/*  details  (Input)                                                         */
/*     is supplementary information regarding why the condition is being     */
/*     signalled.                                                            */

dcl	status		fixed bin (35),
	details		char (*);

dcl	signal_		entry options (variable);

dcl	size		builtin;

%include condition_info_header;

dcl	01 condition_info	aligned like condition_info_header;

	condition_info.length = size (condition_info);
	condition_info.version = 1;
	unspec (condition_info.action_flags) = ""b;
	condition_info.info_string = rtrim (details);
	condition_info.status_code = status;
	call signal_ ("fortran_storage_error", null, addr (condition_info));
     end signal_fortran_storage_error;

/* Snap a VLA Common link. */

snap_link:
     proc (code);

dcl	code		fixed bin (35);

/* Routine to snap a link, if it is unsnapped, and create the VLA common. */

/* Global Inputs:
   atp	  Text pointer.  Pointer to some point in the text section.
   alp    Linkage ptr.   Pointer to start of linkage section in area.linker.
   linkp  Link pointer.  Pointer to the link ptr to be snapped.

   Local Inputs

   code   return error code.

   Outputs:
   storage_ptr Has pointer to start of variable, whether created or not.
   */

dcl	block_name	char (32) varying;

/* if link is unsnapped, then snap it and create the common if necessary. */
/* set_ext_variable_ will also initialize the common.		    */

	if linkp -> link.ft2 = "46"b3			/* unsnapped */
	then do;

/* defp is pointer to definition section. */
/* type_pair points to type_pair word.    */
/* init_info_ptr is initialization block. */

		defp = ptr (atp, alp -> virgin_linkage_header.def_offset);
		type_ptr = addrel (defp, (addrel (defp, linkp -> link.exp_ptr) -> exp_word.type_ptr));
		namep = addrel (defp, type_ptr -> type_pair.ext_ptr);
		block_name = substr (namep -> name.char_string, 1, fixed (namep -> name.nchars, 9));
		init_info_ptr = addrel (defp, type_ptr -> type_pair.trap_ptr);
		call set_ext_variable_ ((block_name), init_info_ptr, stackbaseptr (), found_sw, variablep, code);
		if code ^= 0
		then if ^found_sw
		     then return;

		storage_ptr = variablep -> variable_node.vbl_ptr;
		linkp -> based_ptr = storage_ptr;	/* snap link too */
	     end;

/* accept the previously snapped link. */

	else storage_ptr = linkp -> based_ptr;
	return;
     end snap_link;
%page;
signal_sub_error:
     proc;

/* Subroutine to call sub_err_ if the program has both perprocess static and
   static LA/VLAs.  For now we specify action_cant_restart because
   there is no easy way to reset the active perprocess static flag.
*/

dcl	retval		fixed bin (35);
dcl	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl	dirname		char (168);
dcl	entryname		char (32);
dcl	dirname_length	fixed bin;

	retval = 0;
	call hcs_$fs_get_path_name (textp, dirname, dirname_length, entryname, code);
	call sub_err_ (0, "fortran_storage_", ACTION_CANT_RESTART, null, retval,
	     "Attempt by perprocess static segment ^a>^a^/to use static (very) large arrays.  This combination is illegal."
	     ,
	     dirname, entryname);
	return;					/* should never get here */

     end signal_sub_error;
%page;
%include system_link_init_info;
%include linkdcl;
%include system_link_names;
%include stack_header;

%include sub_err_flags;

     end fortran_storage_;




		    fortran_storage_manager_.pl1    11/20/86  1412.9rew 11/20/86  1142.5      433710



/****^  ******************************************
        *                                        *
        * Copyright, (C) Honeywell Limited, 1983 *
        *                                        *
        ****************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-08-20,DGHowe), approve(86-08-20,MCR7391),
     audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222):
     removed unrequired declarations.
                                                   END HISTORY COMMENTS */


/* format: style3,^delnl,linecom */
fortran_storage_manager_:
fsm_:
     proc options (support);

/*  Author:  H. Hoover,  University of Calgary,  82-08-12.                   */
/*                                                                           */
/*  Modified:                                                                */
/*     84-10-10 by MM - 442:  Set 256K switch once per process.  Do not set  */
/*        it prior to creating a segment.			       */
/*     83-07-10 by TO:  Set 256K switch prior to creating a 256K segment     */
/*     83-06-16 by TO:  Use condition_info_header, have options (support).   */
/*     83-02-15 by TO:  Create get_vla_segnos entry to return information to */
/*	run_ as to the segment numbers created for storage.	       */
/*     83-01-19 by TO:  Allow storage directory per-ring.                    */
/*     83-01-19 by TO:  Set maximum length of segments from                  */
/*        pl1_operators_$VLA_words_per_seg_ for general runtime use.         */
/*     83-01-19 by TO:  Set safety switch for fsm_dir, fsm_info and fsm_segs.*/
/*     82-10-14 by HH:  Allow storage to be allocated from anywhere in the   */
/*        storage heirarchy (rather than just the process directory) and     */
/*        allow multiple processes to share the same pool of free segments.  */

/*  Function:  to allocate, free and list storage in connection with large   */
/*     and very large 'fortran' arrays.                                      */

/*  Error processing:                                                        */
/*                                                                           */
/*  The entry points in this procedure do not return a status code if an     */
/*  error occurs.  Instead, the condition 'fortran_storage_manager_error' is */
/*  signalled with a description of what the error is.  If the user chooses  */
/*  to restart, we assume he has done something to fix the problem and we    */
/*  retry the operation that detected the error.  If the problem is not      */
/*  fixed, we again signal the condition 'fortran_storage_manager_error'.    */
/*  This continues ad nauseum until either the user fixes the problem or     */
/*  gives up and releases.					       */

dcl	get_lock_id_	entry returns (bit (36) aligned);

dcl	False		bit (1) static options (constant) init ("0"b),
	True		bit (1) static options (constant) init ("1"b),
	fsm_dir_name_master char (8) static options (constant) init ("fsm_dir_"),
	fsm_info_name	char (13) static options (constant) init ("fsm_info.fsm_");
     

dcl	01 fsm_info	aligned based (fsm_info_ptr),
	  02 lock		bit (36),			/*  Lock word.  */
	  02 seg_cnt	fixed bin,		/*  Total number of allocated and free segments.  */
	  02 seg		(fsm_info.seg_cnt),
	    03 owning_process
			bit (36),			/*  Lock ID for owning process.  ""b => Free.  */
	    03 owner	ptr unal,			/*  Pointer to owner of this segment.  */
	    03 first_seg_in_group
			fixed bin,		/*  Index of first seg in this group.  */
	    03 next_seg_in_group
			fixed bin,		/*  Index of next seg in this group.  */
	    03 seg_num	fixed bin;		/*  Number under which segment is initiated.  */

dcl	fsm_dir_path	char (168) static init (""),
	fsm_info_path	char (168) static init (""),
	fsm_info_ptr	ptr static init (null),
	fsm_info_ptr_valid	bit (1) static init ("0"b);

dcl	me		ptr init (codeptr (fsm_)),
	my_process	bit (36) aligned init (get_lock_id_ ());


	return;					/*  Just ignore calls to the main entry point.  */

alloc:
     entry (num_segs_desired, owner, first_seg_ptr);

/*  Function:  to allocate a specified number of segments with consecutive   */
/*     segment numbers.  The segments are created as needed.                 */

/*  Arguments:                                                               */
/*                                                                           */
/*  num_segs_desired  (Input)                                                */
/*     is the number of segments to be allocated.                            */
/*                                                                           */
/*  owner  (Input)                                                           */
/*     is the address of a location which is considered to own the segments  */
/*     to be allocated.  It is used to identify the segments which are to be */
/*     deallocated by a call to the 'free' routine.                          */
/*                                                                           */
/*  first_seg_ptr  (Output)                                                  */
/*     is the address of the base of the first segment allocated.  (The      */
/*     addresses of the other segments are obtained by incrementing the      */
/*     segment number portion of the address of the first segment.)  The     */
/*     value 'null' is returned if 'num_segs_desired' is less than 1 or if   */
/*     'owner' is 'null' or the 'fortran_storage_manager_' entry point.      */

/*  Error handling:                                                          */
/*                                                                           */
/* If an error occurs during allocation, the 'fortran_storage_manager_error' */
/*   condition is signalled.  If the user does not handle the condition, the */
/*   system  will  display a diagnostic describing the error that caused the */
/*   condition  to  be  signalled  and  establish  a new command level.  The */
/*   'start'  command will cause the code that failed to be retried.  If the */
/*  problem which caused the failure has been fixed, allocation will proceed */
/*   as  though  the  error  had  never  occurred;  otherwise, the condition */
/*  'fortran_storage_manager_error' will be signalled again.	       */
/*                                                                           */
/*  There is one error that can occur which the user need only restart the   */
/*  allocation in order to correct:  'The segment number is in use.'  This   */
/*  should only occur if the user suspends the allocation process with a     */
/*  'quit' signal, does something that requires a new segment to be made     */
/*  known, then restarts the allocation.  If the new segment is made known   */
/*  under a segment number that was to be used for one of the segments being */
/*  allocated, the above error occurs.  Restarting after such an error will  */
/*  cause a new set of sequential segment numbers to be chosen.              */

dcl	num_segs_desired	fixed bin,
	owner		ptr,
	first_seg_ptr	ptr;

dcl	hcs_$initiate	entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
	hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)),
	pathname_		entry (char (*), char (*)) returns (char (168));

/* builtins */

dcl       (addr, addrel, baseno, baseptr, before, bin, char, codeptr,
	fixed, hbound, index, lbound, length, ltrim, ptr, rel, rtrim,
	size, substr, sum, unspec, verify, null)		builtin;

dcl	cleanup		condition;

dcl	first_seg_in_group	fixed bin,
	first_seg_num	fixed bin,
	prev_seg_in_group	fixed bin,
	seg_idx		fixed bin,
	seg_num		fixed bin,
	status		fixed bin (35),
	try_again		bit (1);


/*  Verify that the input arguments are valid.  */

	first_seg_ptr = null;
	if num_segs_desired <= 0 | owner = null | owner = me
	then return;

	on cleanup call release_fsm_info;
	call appropriate_fsm_info;

/*  Allocate the requested segments, specifying this object segment as the   */
/*  owner, so that if we have to do a clean up, we will know which segments  */
/*  we must deallocate.                                                      */

	try_again = True;
	do while (try_again);
	     try_again = False;
	     call pick_first_seg_num (num_segs_desired, first_seg_num);
	     do seg_num = first_seg_num to first_seg_num + num_segs_desired - 1 while (^try_again);
		call pick_seg (seg_idx);
		if seg_num = first_seg_num
		then first_seg_in_group = seg_idx;
		else fsm_info.seg (prev_seg_in_group).next_seg_in_group = seg_idx;
		fsm_info.seg (seg_idx).owning_process = my_process;
		fsm_info.seg (seg_idx).owner = me;
		fsm_info.seg (seg_idx).first_seg_in_group = first_seg_in_group;
		fsm_info.seg (seg_idx).next_seg_in_group = 0;
		fsm_info.seg (seg_idx).seg_num = seg_num;
		call hcs_$initiate (fsm_dir_path, seg_name (seg_idx), "", 1, 0, baseptr (seg_num), status);
		if status ^= 0
		then do;
			call signal_fsm_error (status,
			     "(Trying to initiate " || pathname_ (fsm_dir_path, seg_name (seg_idx))
			     || " as segment "
			     || octal_representation (seg_num) || ")");
			do seg_idx = first_seg_in_group repeat fsm_info.seg (seg_idx).next_seg_in_group
			     while (seg_idx ^= 0);
			     call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status);
			end;
			try_again = True;
		     end;
		prev_seg_in_group = seg_idx;
	     end;
	end;

/*  Transfer ownership of the allocated segments to the caller.  */

	do seg_idx = 1 to fsm_info.seg_cnt;
	     if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = me
	     then fsm_info.seg (seg_idx).owner = owner;
	end;
	first_seg_ptr = baseptr (first_seg_num);
	call release_fsm_info;
	return;

free:
     entry (owner);

/*  Function:  to free all segments previously allocated to a specified      */
/*     owner.                                                                */

/*  Arguments:                                                               */
/*                                                                            */
/*  owner  (Input)                                                           */
/*     is the address of the location that was specified (at allocation) to  */
/*     be the owner of the segments that are now desired to be deallocated.  */
/*     If there are no allocated segments with the specified owner, the      */
/*     routine just returns, without comment.                                */

dcl	hcs_$truncate_file	entry (char (*), char (*), fixed bin (19), fixed bin (35));

	on cleanup call release_fsm_info;
	call appropriate_fsm_info;

	do seg_idx = 1 to fsm_info.seg_cnt;
	     if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = owner
	     then do;
		     call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status);
		     call hcs_$truncate_file (fsm_dir_path, seg_name (seg_idx), 0, status);
		     unspec (fsm_info.seg (seg_idx)) = ""b;
		end;
	end;
	call release_fsm_info;
	return;

get_owner:
     entry (seg_ptr, owner);

/*  Function:  to return the owner of a specified managed segment.  If the   */
/*     specified segment is free or is not one of those managed by 'fsm_',   */
/*     'null' is returned.                                                   */

/*  Arguments:                                                               */
/*                                                                           */
/*  seg_ptr  (Input)                                                         */
/*     is a pointer to any location in the segment whose owner is desired.   */

dcl	seg_ptr		ptr;

	on cleanup call release_fsm_info;
	call appropriate_fsm_info;
	do seg_idx = 1 to fsm_info.seg_cnt
	     while (fsm_info.seg (seg_idx).owning_process ^= my_process
	     | fsm_info.seg (seg_idx).seg_num ^= bin (baseno (seg_ptr)));
	end;
	if seg_idx <= fsm_info.seg_cnt
	then owner = fsm_info.seg (seg_idx).owner;
	else owner = null;
	call release_fsm_info;
	return;

get_vla_segnos:
     entry (segment_map_bits);

/*  Function:  to return a bit array with bits set for each segment created  */
/*     by fortran_storage_manager_ in this process.		       */

/*  Arguments:                                                               */
/*                                                                           */
/*  segment_map_bits (Input/Output)                                          */
/*     is an array (*) of bits which is passed in.  This routine will set    */
/*     bits corresponding to the segment numbers of external storage segments*/

dcl	segment_map_bits	(*) bit (1);

	on cleanup call release_fsm_info;
	call appropriate_fsm_info;

/*   Scan the groups of segments allocated to this process.                  */

	do seg_idx = 1 to fsm_info.seg_cnt;
	     if fsm_info.owning_process (seg_idx) = my_process
	     then segment_map_bits (seg_idx) = "1"b;
	end;
	call release_fsm_info;
	return;

list_fortran_storage:
lfs:
     entry;

/*  Function:  to list (on the 'user_output' switch) the segments which are  */
/*     currently allocated to this process.                                  */

dcl	ioa_		entry options (variable);

dcl	group_cnt		fixed bin;


	on cleanup call release_fsm_info;
	call appropriate_fsm_info;

/*  Count the number of groups of segments that are allocated to this        */
/*  process.                                                                 */

	group_cnt = 0;
	do seg_idx = 1 to fsm_info.seg_cnt;
	     if fsm_info.owning_process (seg_idx) = my_process & fsm_info.first_seg_in_group (seg_idx) = seg_idx
	     then group_cnt = group_cnt + 1;
	end;

/*  If there are any segments allocated to this process, list them by owner  */
/*  and group.                                                               */

	if group_cnt = 0
	then call ioa_ ("No segments in ^a allocated to this process.", fsm_dir_path);
	else do;
		call ioa_ ("Segments in ^a allocated to this process:", fsm_dir_path);
		call list_groups (group_cnt, my_process);
	     end;
	call release_fsm_info;
	return;

appropriate_fsm_info:
     proc;

/*  Function:  to find and lock for this process 'fsm_info'.  'fsm_info' and */
/*     its containing directory will be created if necessary.                */

/*  Global arguments:                                                        */
/*                                                                           */
/*  fsm_dir_name_master  (Input)                                             */
/*     is the name of the directory where the segment on which 'fsm_info' is */
/*     based resides. (Ring number will be added later to create the dir.)   */
/*                                                                           */
/*  fsm_dir_path  (Output)                                                   */
/*     is the absolute pathname of the directory where the segment on which  */
/*     'fsm_info' is based resides.                                          */
/*                                                                           */
/*  fsm_info_name  (Input)                                                   */
/*     is the name of the segment on which 'fsm_info' is based.              */
/*                                                                           */
/*  fsm_info_ptr  (Output)                                                   */
/*     is the address of the base of the segment on which 'fsm_info' is      */
/*     based.                                                                */

dcl	error_table_$bad_segment
			fixed bin (35) ext,
	error_table_$invalid_lock_reset
			fixed bin (35) ext,
	error_table_$moderr fixed bin (35) ext,
	error_table_$noentry
			fixed bin (35) ext,
	error_table_$notadir
			fixed bin (35) ext,
	error_table_$nomatch
			fixed bin (35) ext;

dcl	cu_$level_get	entry returns (fixed bin (3)),
	get_group_id_$tag_star
			entry returns (char (32)),
	get_system_free_area_
			entry returns (ptr),
	hcs_$add_acl_entries
			entry (char (*), char (*), ptr, fixed bin, fixed bin (35)),
	hcs_$append_branchx
			entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1),
			fixed bin (1),
			fixed bin (24), fixed bin (35)),
	hcs_$make_seg	entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
	hcs_$set_safety_sw	entry (char (*), char (*), bit (1), fixed bin (35)),
	hcs_$set_256K_switch
			entry (bit (2) aligned, bit (2) aligned, fixed bin (35)),
	hcs_$star_	entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
	hcs_$status_minf	entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)),
	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) external,
	set_lock_$lock	entry (bit (36) aligned, fixed bin, fixed bin (35)),
	sys_info$max_seg_size
			fixed bin (35) ext;

dcl	cleanup		condition;

dcl	Chase_links	fixed bin (1) static options (constant) init (1),
	Max_wait_time	fixed bin static options (constant) init (120);

dcl	01 acl		aligned,
	  02 access_name	char (32),
	  02 modes	bit (36),
	  02 xmodes	bit (36),
	  02 status	fixed bin (35);

dcl	bit_count		fixed bin (24),
	fsm_dir_dir_path	char (168),
	fsm_dir_name	char (32),
	i		fixed bin,
	max_seg_idx	fixed bin,
	primary_name	char (32),
	seg_cnt		fixed bin,
	seg_idx		fixed bin,
	status		fixed bin (35),
	system_free_area_ptr
			ptr init (null),
	type		fixed bin (2);


dcl	system_free_area	area based (system_free_area_ptr);

dcl	get_ring_		entry () returns (fixed bin (3));


/*  If  the  flag 'fsm_info_ptr_valid' is false, we must find 'fsm_info' and */
/*   store the address of its base in 'fsm_info_ptr'.  If 'fsm_info' doesn't */
/*  exist, we must create it (and possibly its containing directory).  If we */
/*   are  unable  to  do this, we signal the 'fortran_storage_manager_error' */
/*   condition  with a description of the problem.  If the user restarts us, */
/*   we  assume  he  has  done  something to correct the problem, and we try */
/*  again.						       */

	if ^fsm_info_ptr_valid
	then do;
		if pl1_operators_$VLA_words_per_seg_ > sys_info$max_seg_size
		then do;
			call hcs_$set_256K_switch ("11"b, (""b), status);
			if status ^= 0
			then call signal_fsm_error (status, "Cannot set 256K switch");
		     end;
		fsm_info_ptr = null;
		fsm_dir_name = fsm_dir_name_master || ltrim (char (get_ring_ ()));
		do while (fsm_info_ptr = null);
		     call get_fsm_dir_dir_path (fsm_dir_dir_path);
		     fsm_dir_path = pathname_ (fsm_dir_dir_path, fsm_dir_name);
		     fsm_info_path = pathname_ (fsm_dir_path, fsm_info_name);
		     call hcs_$status_minf (fsm_dir_dir_path, fsm_dir_name, Chase_links, type, bit_count, status);
		     if status = 0
		     then if type = star_DIRECTORY & bit_count = 0
			then do;			/*  Find 'fsm_info', creating it if necessary.  */
				call hcs_$make_seg (fsm_dir_path, fsm_info_name, "", RW_ACCESS_BIN, fsm_info_ptr,
				     status);
				if status = error_table_$moderr
				then do;		/*  Segment exists, but we don't have access. */
					acl.access_name = get_group_id_$tag_star ();
					acl.modes = RW_ACCESS;
					acl.xmodes = ""b;
					call hcs_$add_acl_entries (fsm_dir_path, fsm_info_name, addr (acl), 1,
					     status);
					if status = 0
					then call hcs_$initiate (fsm_dir_path, fsm_info_name, "", 0, 0,
						fsm_info_ptr, status);
				     end;
				if fsm_info_ptr = null
				then call signal_fsm_error (status, fsm_info_path);
			     end;
			else call signal_fsm_error (error_table_$notadir, fsm_dir_path);
		     else if status = error_table_$noentry
		     then do;			/*  Create 'fsm_dir' and 'fsm_info'.  */
			     call hcs_$append_branchx (fsm_dir_dir_path, fsm_dir_name, SMA_ACCESS_BIN,
				cu_$level_get (),
				get_group_id_$tag_star (), 1, 0, 0, status);
			     if status = 0
			     then do;		/*  Create 'fsm_info'.  */
				     call hcs_$set_safety_sw (fsm_dir_dir_path, fsm_dir_name, "1"b, status);
				     call hcs_$make_seg (fsm_dir_path, fsm_info_name, "", RW_ACCESS_BIN,
					fsm_info_ptr, status);
				     if fsm_info_ptr = null
				     then call signal_fsm_error (status, fsm_info_path);
				     call hcs_$set_safety_sw (fsm_dir_dir_path, fsm_info_name, "1"b, status);
				end;
			     else call signal_fsm_error (status, fsm_dir_path);
			end;
		     else call signal_fsm_error (status, fsm_dir_path);
		end;
	     end;

/*  We  now have a pointer to 'fsm_info'.  However, we cannot use 'fsm_info' */
/*  until we lock it so that we are safe from some other process altering it */
/*   while  we use it.  If some other process is currently using it, we must */
/*   wait  for that process to unlock it.  If that process doesn't unlock it */
/*   in  a  reasonable  time,  we signal the 'fortran_storage_manager_error' */
/*   condition, indicating that this has occurred.  If the user restarts us, */
/*  we try again.						       */

	status = 1;
	do while (status ^= 0);
	     call set_lock_$lock (fsm_info.lock, Max_wait_time, status);
	     if status = error_table_$invalid_lock_reset
	     then status = 0;
	     else if status ^= 0
	     then call signal_fsm_error (status, fsm_info_path);
	end;

/*  We now have 'fsm_info' all to ourselves.  However, it may not be valid.  */
/*  It is fairly expensive to check for validity, so we only do it the first */
/*  time we access 'fsm_info'.  This is reasonable, since serious problems   */
/*  with the information in 'fsm_info' are rare and will be diagnosed later  */
/*  anyway.                                                                  */
/*                                                                           */
/*  There are two ways in which 'fsm_info' could be invalid.  First, it may  */
/*  not be consistent in that it knows about more or fewer managed segments  */
/*  than actually exist in the directory.  Second, it may be out of date in  */
/*  that it has some segments allocated to processes that no longer exist.   */
/*                                                                           */
/*  It  is  easy  to  tell if 'fsm_info' is inconsistent: We need only count */
/*   number  of  managed segments (i.e.  segments whose first component is a */
/*   positive  integer  and  whose  second component is 'fsm_') and find the */
/*   managed  segment whose first component is numerically largest.  We have */
/*   consistency if and only if both these numbers equal 'fsm_info.seg_cnt'. */
/*   If  'fsm_info'  is  inconsistent,  the  'fortran_storage_manager_error' */
/*   condition  is  signalled  with  a description of the problem.  The user */
/*  probably cannot do anything about this, but if he chooses to restart, we */
/*  repeat the validity test.					       */
/*                                                                           */
/*  If 'fsm_info' is found to be consistent, we examine all allocated        */
/*  segments and free any found to be allocated to nonexistent processes.    */

	do while (^fsm_info_ptr_valid);
	     system_free_area_ptr = get_system_free_area_ ();
	     star_entry_ptr, star_names_ptr = null;
	     on cleanup
		begin;				/*  Free anything that was allocated.  */
		     if star_names_ptr ^= null
		     then free star_names in (system_free_area);
		     if star_entry_ptr ^= null
		     then free star_entries in (system_free_area);
		end;
	     call hcs_$star_ (fsm_dir_path, "*.fsm_", star_BRANCHES_ONLY, system_free_area_ptr, star_entry_count,
		star_entry_ptr, star_names_ptr, status);
	     if status ^= 0 & status ^= error_table_$nomatch
	     then call signal_fsm_error (status, fsm_info_path);
	     else do;				/*  Check validity of 'fsm_info_'.  */
		     seg_cnt, max_seg_idx = 0;
		     do i = 1 to star_entry_count;
			primary_name = star_names (star_entries (i).nindex);
			if verify (before (primary_name, "."), "0123456789") = 0
			     & substr (primary_name, 1, 1) ^= "0"
			then do;			/*  This is a managed segment.  */
				seg_cnt = seg_cnt + 1;
				seg_idx = bin (before (primary_name, "."));
				if seg_idx > max_seg_idx
				then max_seg_idx = seg_idx;
			     end;
		     end;
		     if star_names_ptr ^= null
		     then free star_names in (system_free_area);
		     if star_entry_ptr ^= null
		     then free star_entries in (system_free_area);
		     if max_seg_idx ^= seg_cnt | seg_cnt ^= fsm_info.seg_cnt
		     then call signal_fsm_error (error_table_$bad_segment, fsm_info_path);
		     else do;			/*  'fsm_info' is consistent.  */
			     do seg_idx = 1 to fsm_info.seg_cnt;
				if fsm_info.seg (seg_idx).owning_process ^= ""b
				then do;
					call set_lock_$lock ((fsm_info.seg (seg_idx).owning_process), 0, status)
					     ;
					if status = error_table_$invalid_lock_reset
					then do;	/*  The owner is dead.  */
						call hcs_$truncate_file (fsm_dir_path, seg_name (seg_idx), 0,
						     status);
						unspec (fsm_info.seg (seg_idx)) = ""b;
					     end;
				     end;
			     end;
			     fsm_info_ptr_valid = True;
			end;
		end;
	end;
	return;


%include star_structures;
     end appropriate_fsm_info;

description_of_location:
     proc (location) returns (char (256) varying) recursive;

/*  Function:  to return a meaningful description of the location addressed  */
/*     by a pointer variable.  If the segment number of the location is not  */
/*     valid, the description is just the ASCII representation of a pointer  */
/*     and a comment indicating the segment number is invalid.  Otherwise,   */
/*     the segment number portion is replaced by the pathname of the segment */
/*     and the offset potion is dropped if it is zero, or replaced by the    */
/*     entry name if the location is an entry point.  If the location is in  */
/*     an active stack frame or an external variable, the description will   */
/*     include a comment indicating that.                                    */

/*  Arguments:                                                               */
/*                                                                           */
/*  location  (Input)                                                        */
/*     contains the address of the location whose description is desired.    */

dcl	location		ptr;

dcl	get_entry_name_	entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)),
	get_pdir_		entry returns (char (168)),
	hcs_$fs_get_path_name
			entry (ptr, char (*), fixed bin, char (*), fixed bin (35));

dcl	null		builtin,
	stackbaseptr	builtin,
	stackframeptr	builtin;

dcl	False		bit (1) static options (constant) init ("0"b),
	True		bit (1) static options (constant) init ("1"b);

dcl	bit_offset	char (4) varying,
	checking_external_variables
			bit (1),
	description	char (256) varying,
	dir_name		char (168),
	dir_name_len	fixed bin,
	entry_name	char (32),
	hash_table_idx	fixed bin,
	language		char (8) aligned,
	seg_name		char (32),
	seg_num		fixed bin (18),
	status		fixed bin (35),
	vnp		ptr,
	vthp		ptr,
	word_offset	char (8) varying;


	if location = null
	then return ("null");

/*  Create character representations of the word and bit offsets.  */

	if substr (unspec (location), 58, 6) = ""b	/*  Unfortunately, there is no builtin to get the bit offset.  */
	then bit_offset = "";
	else do;
		bit_offset = "(";
		bit_offset = bit_offset || ltrim (char (fixed (substr (unspec (location), 58, 6))));
		bit_offset = bit_offset || ")";
	     end;
	if rel (location) = ""b & bit_offset = ""
	then word_offset = "";
	else do;
		word_offset = "|";
		word_offset = word_offset || octal_representation (fixed (rel (location)));
	     end;

/*  Generate a meaningful description of the location, if possible.  */

	call hcs_$fs_get_path_name (location, dir_name, dir_name_len, seg_name, status);
	if status ^= 0
	then do;					/*  Can't do much as the segment number is invalid.  */
		description = octal_representation (fixed (baseno (location)));
		description = description || word_offset;
		description = description || bit_offset;
		description = description || " (Segment number invalid)";
	     end;
	else do;					/*  We can at least give a pathname instead of a segment number.  */
		if dir_name = ">"
		then description = "";
		else if dir_name = get_pdir_ ()
		then description = "[pd]";
		else description = substr (dir_name, 1, dir_name_len);
		description = description || ">";
		description = description || rtrim (seg_name);
		call get_entry_name_ (location, entry_name, seg_num, language, status);
		if status = 0
		then do;				/*  Give the entry name instead of a word and bit offset.  */
			description = description || "$";
			description = description || rtrim (entry_name);
		     end;
		else do;				/*  Give the word and bit offset, if nonzero.  */
			description = description || word_offset;
			description = description || bit_offset;
		     end;
		if ptr (location, 0) = stackbaseptr
		then do;				/*  See if it's in an active stack frame.  */
			sp = stackframeptr;
			do while (rel (sp) > rel (location) & stack_frame.prev_sp ^= null);
			     sp = stack_frame.prev_sp;
			end;
			if rel (sp) <= rel (location) & rel (stack_frame.next_sp) > rel (location)
			then do;			/*  Indicate who owns the stack frame.  */
				description = description || " (stack_frame";
				if location ^= sp
				then do;
					description = description || "|";
					description =
					     description
					     ||
					     octal_representation (fixed (rel (location)) - fixed (rel (sp)));
					description = description || bit_offset;
				     end;
				description = description || " of ";
				description = description || description_of_location (stack_frame.entry_ptr);
				description = description || ")";
			     end;
		     end;
		else if index (seg_name, ".area.linker") > 0
		then do;				/*  See if the location is in an external variable.  */
			sb = stackbaseptr;
			vthp = stack_header.sys_link_info_ptr;
			if vthp ^= null
			then do;
				checking_external_variables = True;
				do hash_table_idx = lbound (vthp -> variable_table_header.hash_table, 1)
				     to hbound (vthp -> variable_table_header.hash_table, 1)
				     while (checking_external_variables);
				     do vnp = vthp -> variable_table_header.hash_table (hash_table_idx)
					repeat vnp -> variable_node.forward_thread
					while (vnp ^= null & checking_external_variables);
					if baseno (vnp -> variable_node.vbl_ptr) = baseno (location)
					then if rel (vnp -> variable_node.vbl_ptr) <= rel (location)
						&
						rel (
						addrel (vnp -> variable_node.vbl_ptr,
						vnp -> variable_node.vbl_size))
						> rel (location)
					     then do;
						/*  Indicate the name of the external variable.  */
						     checking_external_variables = False;
						     description = description || " (External Variable ";
						     description = description || vnp -> variable_node.name;
						     if vnp -> variable_node.vbl_ptr ^= location
						     then do;
							     description = description || "|";
							     description =
								description
								||
								octal_representation (
								fixed (rel (location))
								-
								fixed (rel (vnp -> variable_node.vbl_ptr))
								);
							     description = description || bit_offset;
							end;
						     description = description || ")";
						end;
				     end;
				end;
			     end;
		     end;
	     end;
	return (description);


%include stack_frame;
%include stack_header;
%include system_link_names;
     end description_of_location;

get_fsm_dir_dir_path:
     proc (fsm_dir_dir_path);

/*  Function:  to return the pathname of the directory which will contain    */
/*     the directory of segments managed by 'fsm_'.  This pathname is        */
/*     obtained from the variable 'fsm_dir_dir_path' in the user's per-      */
/*     process value segment or default permanent value segment (with the    */
/*     value in the perprocess value segment taking precedent if it is       */
/*     defined differently in the two value segments).  If neither of these  */
/*     value segments define the variable, or if the value is "", then the   */
/*     pathname of the process directory is returned.  If the defined value  */
/*     is not an absolute pathname (i.e. does not start with ">"), the       */
/*     condition 'fortran_storage_manager_error' is signalled with a         */
/*     description of the problem. If this occurs, the user should fixed the */
/*     value segment and restart.  				       */

/*  Arguments:                                                               */
/*                                                                           */
/*  fsm_dir_dir_path  (Output)                                               */
/*     is the absolute pathname of the directory which will contain the      */
/*     directory of segments managed by 'fsm_'.                              */

dcl	fsm_dir_dir_path	char (*);

dcl	error_table_$not_abs_path
			fixed bin (35) ext;

dcl	get_pdir_		entry returns (char (168)),
	value_$get	entry (ptr, bit (36) aligned, char (*), char (*), fixed bin (35));

dcl	status		fixed bin (35);


	fsm_dir_dir_path = "";
	do while (fsm_dir_dir_path = "");
	     call value_$get (null, "11"b, "fsm_dir_dir_path", fsm_dir_dir_path, status);
	     if fsm_dir_dir_path = ""
	     then fsm_dir_dir_path = get_pdir_ ();
	     else if substr (fsm_dir_dir_path, 1, 1) ^= ">"
	     then do;
		     call signal_fsm_error (error_table_$not_abs_path,
			"Value segment specifies 'fsm_dir_dir_path' = " || fsm_dir_dir_path);
		     fsm_dir_dir_path = "";
		end;
	end;
     end get_fsm_dir_dir_path;

list_groups:
     proc (max_group_cnt, desired_process);

/*  Function: to list (on the 'user_output' switch) the groups of segments   */
/*     which are allocated to a specified process.  The groups are listed by */
/*     owner.                                                                */

/*  Arguments:                                                               */
/*                                                                           */
/*  max_group_cnt  (Input)                                                   */
/*     is the maximum number of groups to be listed.  If there are more      */
/*     groups than this, the excess are ignored without comment.             */
/*                                                                           */
/*  desired_process  (Input)                                                 */
/*     is the ID of the process whose groups are to be listed.               */
/*                                                                           */

dcl	max_group_cnt	fixed bin,
	desired_process	bit (36) aligned;

dcl	get_line_length_$stream
			entry (char (*), fixed bin (35)) returns (fixed bin),
	ioa_$nnl		entry options (variable);

dcl	01 expected_group	aligned like group;

dcl	01 group		(max_group_cnt) aligned,
	  02 owner	ptr unaligned,
	  02 first_seg_in_group
			fixed bin;

dcl	expected_group_idx	fixed bin,
	group_cnt		fixed bin,
	group_idx		fixed bin,
	line_len		fixed bin,
	max_line_len	fixed bin,
	name		char (32) varying,
	prev_group_owner	ptr unaligned,
	seg_idx		fixed bin,
	status		fixed bin (35),
	trial_group_idx	fixed bin;

/*  Store in 'group' the owner and number of the first segment of each group */
/*  allocated to this process.                                               */

	group_cnt = 0;
	do seg_idx = 1 to fsm_info.seg_cnt while (group_cnt < max_group_cnt);
	     if fsm_info.seg (seg_idx).owning_process = desired_process
		& fsm_info.seg (seg_idx).first_seg_in_group = seg_idx
	     then do;
		     group_cnt = group_cnt + 1;
		     group (group_cnt).owner = fsm_info.owner (seg_idx);
		     group (group_cnt).first_seg_in_group = fsm_info.first_seg_in_group (seg_idx);
		end;
	end;

/*  Sort groups into ascending order of owner and number of first segment in */
/*  the group.                                                               */

	do group_idx = 1 to group_cnt - 1;
	     expected_group = group (group_idx);
	     expected_group_idx = group_idx;
	     do trial_group_idx = group_idx + 1 to group_cnt;
		if unspec (group (trial_group_idx)) < unspec (expected_group)
		then do;
			expected_group = group (trial_group_idx);
			expected_group_idx = trial_group_idx;
		     end;
	     end;
	     if group_idx ^= expected_group_idx
	     then do;
		     group (expected_group_idx) = group (group_idx);
		     group (group_idx) = expected_group;
		end;
	end;

/*  List the groups.  */

	max_line_len = get_line_length_$stream ("user_output", status);
	unspec (prev_group_owner) = ""b;		/*  Start with an impossible owner.  */
	do group_idx = 1 to group_cnt;
	     if group (group_idx).owner ^= prev_group_owner
	     then do;				/*  Describe new owner.  */
		     prev_group_owner = group (group_idx).owner;
		     call ioa_$nnl ("^/^a owns:^/", description_of_location ((prev_group_owner)));
		end;
	     call ioa_$nnl ("^4x");
	     line_len = 4;
	     do seg_idx = group (group_idx).first_seg_in_group repeat fsm_info.next_seg_in_group (seg_idx)
		while (seg_idx ^= 0);
		name = rtrim (seg_name (seg_idx));
		if line_len + 1 + length (name) <= max_line_len
		then do;
			line_len = line_len + 1 + length (name);
			call ioa_$nnl (" ^a", name);
		     end;
		else do;
			line_len = 10 + length (name);
			call ioa_$nnl ("^/^-^a", name);
		     end;
	     end;
	     call ioa_$nnl ("^/");
	end;

     end list_groups;

octal_representation:
     proc (value) returns (char (12) varying);

/*  Function:  to return the octal representation of an integer value.       */

/*  Arguments:                                                               */
/*                                                                           */
/*  value  (Input)                                                           */
/*     is the integer value whose octal representation is desired.           */

dcl	value		fixed bin;

dcl	cv_bin_$oct	entry (fixed bin, char (12) aligned);

dcl	string		char (12) aligned;

	call cv_bin_$oct (value, string);
	return (ltrim (string));
     end octal_representation;

pick_first_seg_num:
     proc (num_segs_desired, first_seg_num);

/*  Function:  to find a set of a specified size of free, consecutive        */
/*     segment numbers and return the first segment number of the set.       */

/*  Arguments:                                                               */
/*                                                                           */
/*  num_segs_desired  (Input)                                                */
/*     is the number of consecutive segment numbers needed.                  */
/*                                                                           */
/*  first_seg_num  (Output)                                                  */
/*     is the first segment number of the chosen set of consecutive segment  */
/*     numbers.                                                              */

dcl	num_segs_desired	fixed bin,
	first_seg_num	fixed bin;

dcl	hcs_$high_low_seg_count
			entry (fixed bin, fixed bin);

dcl	best_hole_size	fixed bin,
	best_hole_start	fixed bin,
	cur_hole_size	fixed bin,
	found_highest_seg_num_in_use
			bit (1),
	high_seg_num	fixed bin,
	high_seg_num_minus_low_seg_num
			fixed bin,
	low_seg_num	fixed bin,
	seg_num		fixed bin;

/*  Find the lowest segment number allowed to be used and the highest that   */
/*  is currently in use.                                                     */

	call hcs_$high_low_seg_count (high_seg_num_minus_low_seg_num, low_seg_num);
	high_seg_num = high_seg_num_minus_low_seg_num + low_seg_num;
	low_seg_num = low_seg_num + 8;		/*  First 8 reserved for stacks.  */
	found_highest_seg_num_in_use = False;
	do while (^found_highest_seg_num_in_use);
	     if seg_num_free (high_seg_num)
	     then high_seg_num = high_seg_num - 1;
	     else found_highest_seg_num_in_use = True;
	end;

/*  Search from the lowest segment number allowed to be used to the highest  */
/*  in use for the smallest set of consecutive segment numbers that is at    */
/*  least as big as needed.                                                  */

	best_hole_size, cur_hole_size = 0;
	do seg_num = low_seg_num to high_seg_num while (best_hole_size ^= num_segs_desired);
	     if seg_num_free (seg_num)
	     then cur_hole_size = cur_hole_size + 1;
	     else do;
		     if cur_hole_size >= num_segs_desired
		     then if best_hole_size = 0 | best_hole_size > cur_hole_size
			then do;			/*  Latest hole is best fit so far.  */
				best_hole_size = cur_hole_size;
				best_hole_start = seg_num - best_hole_size;
			     end;
		     cur_hole_size = 0;
		end;
	end;

/*  If we found a hole large enough, choose the first segment number in it   */
/*  as the start of the desired set; otherwise, start the set immediately    */
/*  following the highest segment number currently in use.                   */

	if best_hole_size < num_segs_desired
	then first_seg_num = high_seg_num + 1;
	else first_seg_num = best_hole_start;
     end pick_first_seg_num;

pick_seg:
     proc (seg_idx);

/*  Function:  to choose a free segment to be allocated.  If there are none, */
/*     one is created.                                                       */

/*  Arguments:                                                               */
/*                                                                           */
/*  seg_idx  (Output)                                                        */
/*     is the index of the element in 'fsm_info.seg' which corresponds to    */
/*     the segment which has been chosen.                                    */

dcl	seg_idx		fixed bin;

dcl	get_group_id_	entry returns (char (32)),
	hcs_$append_branch	entry (char (*), char (*), fixed bin (5), fixed bin (35)),
	hcs_$replace_acl	entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)),
	hcs_$set_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)),
	hcs_$set_safety_sw	entry (char (*), char (*), bit (1), fixed bin (35)),

	pl1_operators_$VLA_words_per_seg_
			fixed bin (19) external;

dcl	01 acl		aligned,
	  02 access_name	char (32),
	  02 modes	bit (36),
	  02 xmodes	bit (36),
	  02 status	fixed bin (35);

dcl	status		fixed bin (35);

	do seg_idx = 1 to fsm_info.seg_cnt while (fsm_info.seg (seg_idx).owning_process ^= ""b);
	end;
	if seg_idx <= fsm_info.seg_cnt
	then do;					/*  Reuse free segment.  */
		acl.access_name = get_group_id_ ();
		acl.modes = RW_ACCESS;
		acl.xmodes = ""b;
		status = 1;
		do while (status ^= 0);
		     call hcs_$replace_acl (fsm_dir_path, seg_name (seg_idx), addr (acl), 1, "0"b, status);
		     if status ^= 0
		     then call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx)));
		end;
	     end;
	else do while (seg_idx > fsm_info.seg_cnt);	/*  Create a segment.  */
		call hcs_$append_branch (fsm_dir_path, seg_name (seg_idx), RW_ACCESS_BIN, status);
		if status = 0
		then do;
			fsm_info.seg_cnt = seg_idx;
			fsm_info.seg (seg_idx).owner = null;
			call hcs_$set_max_length (fsm_dir_path, seg_name (seg_idx),
			     pl1_operators_$VLA_words_per_seg_, status);
			if status ^= 0
			then call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx)));

			call hcs_$set_safety_sw (fsm_dir_path, seg_name (seg_idx), "1"b, status);
		     end;
		else call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx)));
	     end;
     end pick_seg;

release_fsm_info:
     proc;

/*  Function:  to free any segments that have been allocated to 'fsm_', then */
/*     to unlock 'fsm_info' so it can be used by other processes.            */

dcl	hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)),
	set_lock_$unlock	entry (bit (36) aligned, fixed bin (35));

dcl	seg_idx		fixed bin,
	status		fixed bin (35);


/*  This routine may be called in response to a 'cleanup' condition before   */
/*  'fsm_info' has been locked for this process, or possibly even found.     */
/*  Thus, we must be careful to check for these possibilities.               */

	if fsm_info_ptr ^= null
	then if fsm_info.lock = my_process
	     then do;				/*  'fsm_info' is locked for this process.  */
		     do seg_idx = 1 to fsm_info.seg_cnt;
			if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = me
			then do;
				call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status);
				unspec (fsm_info.seg (seg_idx)) = ""b;
			     end;
		     end;
		     status = 1;
		     do while (status ^= 0);
			call set_lock_$unlock (fsm_info.lock, status);
			if status ^= 0
			then call signal_fsm_error (status, "Trying to unlock 'fsm_info'.");
		     end;
		end;
     end release_fsm_info;

seg_name:
     proc (seg_idx) returns (char (32));

/*  Function:  to return the name of the segment associated with a specified */
/*     element of 'fsm_info.seg'.  The name is 'N.fsm_', where 'N' is the    */
/*     decimal representation of the index of the specified element.         */

/*  Arguments:                                                               */
/*                                                                           */
/*  seg_idx  (Input)                                                         */
/*     is the index of the element of 'fsm_info.seg' with which the segment  */
/*     is associated.                                                        */

dcl	seg_idx		fixed bin;

	return (ltrim (char (seg_idx)) || ".fsm_");
     end seg_name;

seg_num_free:
     proc (seg_num) returns (bit (1));

/*  Function:  to indicate whether a given segment number is currently in    */
/*     use.  (Since there is no system function to do this, we fake it by    */
/*     asking for the unique-id of the segment corresponding to the segment  */
/*     number.  If the return code is 'error_table_$invalidsegno', then the  */
/*     segment number is free.)                                              */

/*  Arguments:                                                               */
/*                                                                           */
/*  seg_num  (Input)                                                         */
/*     is the segment number to be tested.                                   */

dcl	seg_num		fixed bin;

dcl	error_table_$invalidsegno
			fixed bin (35) ext;

dcl	hcs_$get_uid_seg	entry (ptr, bit (36) aligned, fixed bin (35));

dcl	status		fixed bin (35),
	uid		bit (36) aligned;

	call hcs_$get_uid_seg (baseptr (seg_num), uid, status);
	if status = error_table_$invalidsegno
	then return (True);
	else return (False);
     end seg_num_free;

signal_fsm_error:
     proc (status, details);

/*  Function:  to signal the restartable condition                          */
/*          'fortran_storage_manager_error'.              		      */

/*  Arguments:                                                               */
/*                                                                           */
/*  status  (Input)                                                          */
/*     is a standard system status code describing why the condition is      */
/*     being signalled.                                                      */
/*                                                                           */
/*  details  (Input)                                                         */
/*     is supplementary information regarding why the condition is being     */
/*     signalled.                                                            */

dcl	status		fixed bin (35),
	details		char (*);

dcl	signal_		entry options (variable);

%include condition_info_header;

dcl	01 condition_info	aligned like condition_info_header;

	condition_info.length = size (condition_info);
	condition_info.version = 1;
	unspec (condition_info.action_flags) = ""b;
	condition_info.info_string = rtrim (details);
	condition_info.status_code = status;
	call signal_ ("fortran_storage_manager_error", null, addr (condition_info));
     end signal_fsm_error;

%include access_mode_values;
     end fortran_storage_manager_;




		    general_format_parse_.pl1       07/30/86  0917.6rew 07/28/86  1458.5      287352



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



/****^  HISTORY COMMENTS:
  1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 462.
  2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter),
     install(86-07-28,MR12.0-1105):
     Fix fortran bug 122.
                                                   END HISTORY COMMENTS */


/* Modified:
          25 Nov 85, RW - 122: Raised the max number of items in a format
                    statement to 1023, up from 510
	18 Jul 85, BW - 462: Detect implementation restriction that 131071
     		(2**17 - 1) is the maximum value that an r, w, or d field
     		can be.
	01 Nov 84, BW - 445: Allow use of * to indicate list-directed I/0.
	30 Oct 82, HH - 115: Conform to the FORTRAN/77 Standard for D, E, F
		and G formats by removing restrictions that d <= w and
		w - d >= size of exponent field.
	09 Sep 82, HH - 114: Allow unary plus sign wherever unary minus is
		allowed.
	27 Apr 82, HH - Defer range check on scale factor to runtime.
	26 Apr 82, HH - Ignore NUL's outside of Hollerith's.
	24 July,1981 MEP - add new features for FORTRAN77, comment the code better, slightly alter the layout of the code
	23 May, 1978, DSL - fix code that zeros unused portion of last word.
	March, April 1978, DSL - To implement new format.
   modified March 1973 by A. Downing to be used at compile time and run time.
   modified June, 1976 by D.S.Levin to clean up and to implement s- and :-formats.
   modified April 7, 1977 David Levin - improve error messages.
*/

/* format: style2 */
general_format_parse_:
     proc (source_chars, encoded_format, ansi77, error_code);

/* parameter */
	dcl     source_chars	 char (1320) aligned;
						/* INPUT */
	dcl     encoded_format	 char (4096) aligned;
						/* OUTPUT */
	declare ansi77		 bit (1) aligned;	/* INPUT */
	dcl     error_code		 fixed bin (35);	/* OUTPUT */

/* automatic */
	dcl     V_format_location	 fixed bin;	/* if a v_format, where it is */
	dcl     asterisk_format_location
				 fixed bin;	/* if an asterisk_format, where it is */
	dcl     ch		 char (1) aligned;	/* quote char */
	dcl     char_type		 fixed bin;	/* ascii value of character */
	dcl     d			 fixed bin;	/* precision field */
	dcl     digit_encountered	 bit (1) aligned;
	dcl     dollar_format_location fixed bin;	/* if a dollar-format, where it is */
	declare expon_field		 fixed bin;	/* width in g and e formats */
	dcl     field_count		 fixed bin;	/* number of fields in encoded format */
	dcl     first_string	 fixed bin;	/* location of first Hollerith in encoded fmt */
	dcl     fmt_spec		 fixed bin;	/* coded format specifier as understood by interpreter */
	dcl     from_runtime	 bit (1) aligned;	/* if called at runtime */
	dcl     i			 fixed bin;
	dcl     in		 fixed bin;	/* index in source_chars */
	dcl     input_ptr		 ptr;
	dcl     j			 fixed bin;
	dcl     last_string		 fixed bin;	/* like first string */
	dcl     minus_encountered	 bit (1) aligned;	/* if a minus before digits */
	dcl     new_state		 fixed bin;	/* NEXT state of finite state machine */
	dcl     out		 fixed bin;	/* index into encoded fomt */
	dcl     output_ptr		 ptr;
	dcl     p			 ptr;
	dcl     paren_count		 fixed bin;	/* nested paren level */
	dcl     paren_stored	 (100) bit (1) aligned;
						/* for rep count of paren fields */
	dcl     prev_delim		 fixed bin;	/* value of last delimiter */
	dcl     r			 fixed bin;	/* repition count */
	dcl     state		 fixed bin;	/* PRESENT state */
	dcl     w			 fixed bin;	/* width field */

	dcl     1 fields		 aligned structure,
		2 spec		 fixed bin (17) unal,
		2 rep_factor	 fixed bin (17) unal,
		2 width		 fixed bin (17) unal,
		2 precision	 fixed bin (17) unal;

/* constants */

	declare ALLOWED		 char (42) internal static options (constant)
				 init ("-format allowed in a format specification.");
	declare FALSE		 bit (1) aligned internal static options (constant) initial ("0"b);
	declare LIST_DIRECTED_ERROR	 char (63) internal static options (constant)
				 initial ("V-format can only appear with line number skipping or $-format.");
	declare LIST_DIRECTED_ERROR2	 char (74) internal static options (constant)
				 initial (
				 "*-format can only appear with line number skipping, $-format, or a-format.");
	declare ONLY1		 char (9) internal static options (constant) initial ("Only one ");
	declare TRUE		 bit (1) aligned internal static options (constant) initial ("1"b);
	declare WHITE		 char (3) aligned int static options (constant) initial (" 	");
						/* SP, TAB and NUL */
	declare WITH_CONTEXT	 bit (1) aligned internal static options (constant) initial ("1"b);
	declare NO_CONTEXT		 bit (1) aligned internal static options (constant) initial ("0"b);
	declare ascii_for_zero	 fixed binary internal static options (constant) initial (48);
	dcl     char_mask		 (3) bit (36) aligned int static options (constant)
				 init ("777000000000"b3, "777777000000"b3, "777777777000"b3);
	declare comma		 fixed bin internal static options (constant) initial (2);
	dcl     delimiter		 (2) char (16) varying int static options (constant)
				 init ("Left parenthesis", "Comma");
	declare illegal_char	 fixed binary internal static options (constant) init (22);
	dcl     left_parn		 fixed bin int static options (constant) init (1);
	declare (
	        v_format		 init (28),
	        dollar_format	 init (29),
	        caret		 init (26),
	        tl_format		 init (99),
	        b_format		 init (25),
	        asterisk_format	 init (21)
	        )			 fixed bin int static options (constant);

/* based */

	dcl     1 based_fields	 like fields unaligned based structure;
	dcl     in_fmt		 char (1320) aligned based (input_ptr);
	dcl     1 neat_source_text	 aligned based (input_ptr),
		2 pad1		 char (in) unaligned,
		2 this_char	 char (1) unaligned,
		2 next_char	 char (1) unaligned,
		2 pad2		 char (1320 - in - 2) unaligned;
	declare 1 overlay_for_strings	 aligned based (input_ptr),
		2 pad1		 char (in) unaligned,
		2 rest_of_format	 char (1320 - i) unaligned;
	dcl     1 output_format	 aligned like runtime_format based (output_ptr);
	dcl     word		 (1024) bit (36) aligned based (output_ptr);

/* builtin */

	declare (addr, binary, divide, hbound, index, length, substr, string, unspec, verify)
				 builtin;

/* general format parse is implemented as a finite state machine of sorts.  The states are defined by 
   action_matrix.state_table.  This is a two dimension array, the columns defining the character just seen,
   and the rows the "state" of the format being parsed.

   The entry in the table is the row of the table to use as the next "state".

   There is also action_matrix.action_list, which is used as the index of a label array of actions to take when 
   encountering the input character in the given state.

   The array table_column converts the character just seen to the proper column in the table to use,so reducing
   the size of the table needed, and additional information is kept in the variables type_char and format_spec.  
   For this reason, and for the fact that we do a little special casing and one character look-ahead,
   this is not really a TRUE finite state machine. 
*/

/* A FEW TABLES TO HELP FUTURE MAINTAINERS, basically inverted lists 
   
   char_type versus letter (type 22 is illegal characters)
	0   i	1   f	2   e	3   l	4   d	5   o	6   g
	7  0..9	8   +-	9   r	10  a	11  h	12  x	13  t
	14  p	15  (	16  )	17  /	18  :	19  '"	20 <HT> <SP>
	21  *	22	23  ,	24  .	25  ^	26  b	27  s
	28  v	29  $

 there is an almost one-to-one relation ship between char_type and the fmt_spec as understood
 by fortran_io_.  The differences are that 20 is used for end_of_format, 21 for TL/TR, 22 for extended  I format (Iw.m),
 25 for BN, 26 for BN, 27 for S, 28 for SP, and 29 for SS.

     actions
	1  slash or colon:  terminate and create current format
	2  left paren: implied iteration is 1
	3  right paren: terminate format is necessary
	4  left paren: iteration explicitly given
	5  x-format: implied iteration is 1
	6  plus or minus sign: signed scale factor
	7  build replication factor
	8  a,d,e,f,g,h,i,l,o,r: implied iteration is 1
	9  failure - can't translate
	10 create hollerith from " or '
	11 white space -skip to next character
	12 a,d,e,f,g,h,i,l,o,r: iteration explicitly given
	13 field width is *
	14 create formats with a w,but no d field (a,o,l,r,t,i?)
	15 build  width field
	16 hollerith from h-format
	17 x-format iteration explicitly given
	18 failure - out of place
	19 p-format terminate
	20 create d and f formats
	21 build precision field
	22 build width field, expect precision field
	23 comma as separator
	24 recognize new Iw.m format
	25 failure - no precision field
	26 build specs with neither width nor replication: s, b, v, $, and ^
	27 build exponent field
	28 complete e and g fileds with expon
	29 begin t field
	30 recognize Ef.dEe and Gf.dEe formats 
*/

/* format: off */
/*	Table to convert character to format type. */

dcl	type_char(0:127) fixed bin internal static options(constant) init(

/*		 0   1   2   3   4   5   6   7 */

/* 000 */           20, 22, 22, 22, 22, 22, 22, 22,         /* \000 - \007 */
/* 010 */		22, 20, 22, 22, 22, 22, 22, 22,	/* \010 TAB \012 - \017 */
/* 020 */		22, 22, 22, 22, 22, 22, 22, 22,	/* \020 - \027 */
/* 030 */		22, 22, 22, 22, 22, 22, 22, 22,	/* \030 - \037 */
/* 040 */		20, 22, 19, 22, 29, 22, 22, 19,	/* SP ! " # $ % & ' */
/* 050 */		15, 16, 21,  8, 23,  8, 24, 17,	/* ( ) * + , - . / */
/* 060 */		 7,  7,  7,  7,  7,  7,  7,  7,	/* 0 1 2 3 4 5 6 7 */
/* 070 */		 7,  7, 18, 22, 22, 22, 22, 22,	/* 8 9 : ; < = > ? */
/* 100 */		22, 10, 25, 22,  4,  2,  1,  6,	/* @ A B C D E F G */
/* 110 */		11,  0, 22, 22,  3, 22, 22,  5,	/* H I J K L M N O */
/* 120 */		14, 22,  9, 27, 13, 22, 28, 22,	/* P Q R S T U V W */
/* 130 */		12, 22, 22, 22, 22, 22, 26, 22,	/* X Y Z [ \ ] ^ _ */
/* 140 */		22, 10, 25, 22,  4,  2,  1,  6,	/* ` a b c d e f g */
/* 150 */		11,  0, 22, 22,  3, 22, 22,  5,	/* h i j k l m n o */
/* 160 */		14, 22,  9, 27, 13, 22, 28, 22,	/* p q r s t u v w */
/* 170 */		12, 22, 22, 22, 22, 22, 22, 22);	/* x y z */


	/* table to convert format spec type (or character type) to proper COLUMN for lex action table */

dcl	table_column (0:29) fixed bin internal static options(constant) init(
		1, 2, 2, 1, 2, 1, 2, 3, 4, 1, 1, 6, 7, 8, 9, 10, 11, 12, 12, 14, 15, 16, 18, 5, 13, 17, 17, 17, 17, 17);

	/* the use of this table eliminates the need for a multiplication */

dcl	offset(6) fixed bin options(constant) internal static init(
		0, 18, 36, 54, 72, 90);

	/* The table of actions and new states for each lexical form */

dcl	1 action_matrix(108) aligned internal static structure,

		/* the NEXT state table */

	     2  state_table unaligned fixed bin(17) init(

/*		iloa defg 0..9 +-	,    h	x    t	p    (	)    /:	.    "'	SP   *	sbv  Others
		r								^$	       */
/* Start */	2,   3,	5,   5,	1,   1,	1,   2,	1,   1,	1,   1,	1,   1,	1,   1,	1,   1,

/* Build w, no d */	1,   1,	2,   5,	1,   1,	1,   2,	1,   1,	1,   1,	1,   1,	2,   1,	1,   1,

/* Build w, w/ d */	1,   1,	3,   1,	1,   1,	1,   1,   1,   1,	1,   1,	4,   1,	3,   1,	1,   1,

/* Build d */	1,   1,	4,   5,	1,   1,	1,   2,	1,   1,	1,   1,	6,   1,	4,   1,	1,   1,

/* Build r or p */	2,   3,	5,   1,	1,   1,	1,   1,	1,   1,	1,   1,	1,   1,	5,   1,	1,   1,

/* Build e */	1,   1,   6,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   1,   6,   1,   1,   1),


		/* actions for all occasions */

	  2  action_list unaligned fixed bin(17) init(

/*		iloa defg 0..9 +-	,    h	x    t	p    (	)    /:	.    "'	SP   *	svb  Others 
		r								^$		*/
/* Start */	8,   8,	7,   6,	23,  18,	5,   29,	18,  2,	3,   1,	18,  10,	11,  26,	26,  9,

/* Build w, no d */	18,  18,	15,  14,	14,  18,	18,  14,	18,  18,	14,  14,	24,  14,	11,  13,	18,  9,

/* Build w, w/ d */	25,  25,	15,  25,	25,  25,	25,  25,	25,  25,	25,  25,	22,  25,	11,  25,	25,  9,

/* Build d */	18,  30,	21,  20,	20,  18,	18,  20,	18,  18,	20,  20,	18,  20,	11,  18,	18,  9,

/* Build r or p */	12,  12,	7,   18,	18,  16,	17,  18,	19,  4,	18,  18,	18,  18,	11,  18,	18,  9,

/* Build e */	18,  18,	27,  18,	28,  18,  18,  18,  18,  18,  28,  28,  18,  18,  11,  18,  18,  9);

/* format: on */

%include format_tables;

	from_runtime = FALSE;
	goto common;

runtime:
     entry (source_chars, encoded_format, ansi77, error_code);

	from_runtime = TRUE;

common:						/* copy input argument */
	input_ptr = addr (source_chars);
	output_ptr = addr (encoded_format);

/* Initialize */

	unspec (output_format.header_word) = "0"b;
	output_format.version = fmt_parse_ver1;
	output_format.last_left_paren = 1;		/* default is containing paren */

	paren_count = 0;
	first_string = 0;
	last_string = 0;
	dollar_format_location = 0;
	V_format_location = 0;
	asterisk_format_location = 0;
	field_count = 0;
	new_state = 1;
	out = 0;
	digit_encountered = FALSE;
	prev_delim = 0;
	minus_encountered = FALSE;
	r, w, d, expon_field = 0;

/* Convert old style format to new format. */

	if input_ptr -> runtime_format.version = "0"b & input_ptr -> old_format.fmt (1) = 15 & from_runtime
	then do;
		string (output_format.format_desc_bits) = string (input_ptr -> old_format.format_desc_bits);

		if output_format.list_directed
		then do;
			out = chars_per_word;
			goto list_directed_return;
		     end;

		i = 1;				/* to get into loop */
		do in = 3 repeat in + i while (i ^= 0);

		     if in = input_ptr -> old_format.last_left_paren
		     then output_format.last_left_paren = out + 1;

		     unspec (fields) = unspec (addr (input_ptr -> old_format.fmt (in)) -> based_fields);

		     i = increment_table (fields.spec);
		     goto unpack_fields (i);
unpack_fields (4):
		     d = fields.precision;
unpack_fields (3):
		     w = fields.width;
unpack_fields (2):
		     r = fields.rep_factor;
unpack_fields (1):
		     if fields.spec = end_of_format
		     then i = 0;
		     call store_specification ((fields.spec));
		end;
		goto successful_return;
	     end;

/* find the beginning of the format specifications */

	in = verify (in_fmt, WHITE) - 1;
	if in < 0					/* entire spec is blank */
	then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT);

	if this_char ^= "("				/* must start with left paren */
	then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT);

	in = in - 1;

/* the loop to parse the format specifications begins here */

new_action (11):					/* action=11  No operation, get next char. */
main_loop:					/* get the next character */
	in = in + 1;
	if in >= length (in_fmt)
	then call parse_failure ("Final right parenthesis not found.", NO_CONTEXT);
	j = binary (unspec (this_char), 9, 0);

/* determine format type, if any, and lex type */

	if j > hbound (type_char, 1)
	then char_type = illegal_char;
	else char_type = type_char (j);

/* get new state and do new action */

	state = new_state;
	i = offset (state) + table_column (char_type);
	new_state = state_table (i);
	go to new_action (action_list (i));

/* end of the loop */


new_action (1):					/* Character is a "/" or ":". */
	field_count = field_count + 1;
	call store_specification (char_type);
	go to main_loop;


new_action (2):					/* Character is "(", Implied repetition is 1. */
	r = 1;
	goto left_paren_common;

new_action (4):					/* Character is "(", Explicit repetition given. */
	if r = 0 | minus_encountered
	then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT);

left_paren_common:
	field_count = field_count + 1;
	paren_count = paren_count + 1;
	if paren_count > hbound (paren_stored, 1)
	then call parse_failure ("Too many parenthesis.", WITH_CONTEXT);

/* if this is a level 1 left paren, format starts here when it is repeated. */

	if paren_count = 2
	then output_format.last_left_paren = out + 1;

/* Parens are stored only if repetition count is greater than 1. */

	if r = 1
	then do;
		paren_stored (paren_count) = FALSE;
		r = 0;				/* reset this field. */
	     end;
	else do;
		call store_specification (char_type);
		paren_stored (paren_count) = TRUE;
	     end;

	prev_delim = left_parn;			/* Prohibit delimiter after "(". */
	goto main_loop;


new_action (3):					/* Character is a ")". */
	field_count = field_count + 1;
	paren_count = paren_count - 1;

/* the format "()" is valid only if that is the entire specification */

	if prev_delim ^= 0 & field_count ^= 2
	then call parse_failure (delimiter (prev_delim) || " immediately precedes a right parenthesis.", WITH_CONTEXT);

	if paren_stored (paren_count + 1)
	then call store_specification (char_type);

	if paren_count ^= 0
	then goto main_loop;			/* continue if not last paren */

	call store_specification (end_of_format);
	goto successful_return;

new_action (5):					/* Now have 1x. */
	r = 1;
	goto x_format_common;

new_action (17):					/* Come here if x is preceded by an integer. */
	if r = 0 | minus_encountered
	then call parse_failure ("Field width for x-format must be greater than zero.", WITH_CONTEXT);

x_format_common:
	field_count = field_count + 1;
	call store_specification (char_type);
	go to main_loop;


new_action (6):					/* Plus or minus sign encountered. */
	digit_encountered = FALSE;
	if this_char = "-"
	then minus_encountered = TRUE;
	go to main_loop;


new_action (7):					/* Build repetition factor or scale factor. */
	digit_encountered = TRUE;
	r = r * 10 + j - ascii_for_zero;
	go to main_loop;

new_action (8):					/* Repetition factor = 1. a,d,e,f,g,i,l,o fields. */
	r = 1;
	goto width_only_common;

new_action (12):					/* Repetition factor given. a,d,e,f,g,i,l,o fields. */
	if r = 0 | minus_encountered
	then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT);

width_only_common:
	digit_encountered = FALSE;
	fmt_spec = char_type;
	go to main_loop;

new_action (9):
	call parse_failure ("The character """ || this_char || """ cannot be translated.", WITH_CONTEXT);

new_action (10):					/* Create a character string. */
	field_count = field_count + 1;
	output_format.contains_hollerith = TRUE;
	w = in + 2;
	ch = this_char;				/* pick up delimiting character */

	if first_string = 0
	then first_string = out + 1;
	else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1;
	last_string = out + 1;

/* loop until the terminating delimit character is found */

	do while (TRUE);

	     in = in + 1;				/* skip the delimiter */
	     i = index (rest_of_format, ch) - 1;	/* find the next one */
	     if i < 0
	     then call parse_failure ("Missing string delimiter.", NO_CONTEXT);

	     in = in + i;				/* move up to the delimiter */
	     r = r + i;				/* update length, without delimit char */

	     if next_char ^= ch			/* this delimit char is really the end of the string */
	     then do;
		     call store_specification (char_type);
		     goto main_loop;
		end;

	     in = in + 1;				/* skip first of the pair of delimiters */
	     r = r + 2;				/* length includes both delimiters */
	end;
	go to main_loop;

new_action (13):					/* Field width is "*". */
	field_count = field_count + 1;
	if digit_encountered | fmt_spec ^= a_format
	then call parse_failure ("Invalid use of ""*"".", WITH_CONTEXT);
	w = 4;

	call store_specification (fmt_spec);
	output_format.anyitems = TRUE;
	goto main_loop;

new_action (14):					/* Formats i, l, o, a, h, and t terminate here. */
	field_count = field_count + 1;

/* width must be positive or not_specified (a_format ONLY)
   in unspecified a_format, fortran_io_ should use the char_len of the variable as the width of the field */

	if w = 0
	then if fmt_spec ^= a_format | fmt_spec = a_format & digit_encountered
	     then call parse_failure ("Field width must be greater than zero.", WITH_CONTEXT);
	if fmt_spec = tl_format
	then do;					/* tl format is tr_format, but in a "negative" direction */
		w = -w;
		fmt_spec = tr_format;
	     end;
	else if fmt_spec ^= tr_format & fmt_spec ^= t_format
	then output_format.anyitems = TRUE;

	call store_specification (fmt_spec);
	goto new_action (action_list (table_column (char_type)));

new_action (15):					/* Build field width. */
	digit_encountered = TRUE;
	w = w * 10 + j - ascii_for_zero;
	goto main_loop;

new_action (16):					/* Encode hollerith string. */
	output_format.contains_hollerith = TRUE;
	field_count = field_count + 1;
	if r = 0 | minus_encountered
	then call parse_failure ("Length of hollerith constant must be greater than zero.", WITH_CONTEXT);

	w = in + 2;
	in = in + r;

	if first_string = 0
	then first_string = out + 1;
	else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1;
	last_string = out + 1;

	call store_specification (char_type);
	goto main_loop;

MISPLACED:
new_action (18):					/* missing delimiter.  */
	call parse_failure ("The character """ || this_char || """ is out of place.", WITH_CONTEXT);

new_action (19):					/* End of 'p' specification. */
	field_count = field_count + 1;
	if ^digit_encountered
	then call parse_failure ("Sign must be followed by a digit.", WITH_CONTEXT);
	if minus_encountered
	then r = -r;
	prev_delim = 0;

	call store_specification (char_type);
	goto main_loop;

process_d_field:
new_action (20):					/* Formats f, e, d, and g are defined here. */
	if ^digit_encountered
	then call parse_failure ("Missing precision field.", WITH_CONTEXT);

	output_format.anyitems = TRUE;

	if new_state = 6				/* building expon field */
	then do;
		digit_encountered = FALSE;
		goto main_loop;
	     end;
	else do;					/* no expon field, store it */
		field_count = field_count + 1;
		call store_specification (fmt_spec);
		go to new_action (action_list (table_column (char_type)));
	     end;

new_action (21):					/* Create decimal position. */
	digit_encountered = TRUE;
	d = d * 10 + j - ascii_for_zero;
	go to main_loop;

process_w_field:
new_action (22):					/* Make sure there was a legal numeric field. */
	if w = 0
	then call parse_failure ("Width of field must be greater than zero.", WITH_CONTEXT);
	digit_encountered = FALSE;
	go to main_loop;

new_action (23):					/* Test for legal appearance of a comma. */
	if prev_delim ^= 0
	then call parse_failure (delimiter (prev_delim) || " immediately precedes a comma.", WITH_CONTEXT);

	prev_delim = comma;
	go to main_loop;

new_action (24):					/* possibly unexpected "." */
	if fmt_spec = i_format			/* new Iw.m format indicated */
	then do;
		fmt_spec = extended_i_format;
		new_state = 4;			/* build "precision" field */
		goto process_w_field;
	     end;
	else goto MISPLACED;

new_action (25):
	call parse_failure ("Precision field is omitted.", WITH_CONTEXT);

new_action (26):					/* If char = v and this the only field, list directed */
	if char_type = v_format
	then do;
		if field_count ^= 1 | dollar_format_location ^= 0
		then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT);
		if V_format_location ^= 0
		then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT);

		field_count = field_count + 1;
		V_format_location = field_count + 1;
		prev_delim = 0;
	     end;

	else if char_type = asterisk_format
	then do;
		if field_count ^= 1 | dollar_format_location ^= 0
		then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT);
		if asterisk_format_location ^= 0
		then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT);

		field_count = field_count + 1;
		asterisk_format_location = field_count + 1;
		prev_delim = 0;
	     end;

/* sadly, in ansi 66 mode, s-format meant skip line numbers, now it refers to the processing of leading plus signs.
   so, it is hung on the ansi77 switch input argument.
   To get the same effect in ansi77, use  ^N (the two characters,caret and  N ). */

	else if char_type = s_format
	then do;
		if next_char = "s" | next_char = "S"
		then do;
			in = in + 1;
			call store_specification (ss_format);
		     end;
		else if next_char = "p" | next_char = "P"
		then do;
			in = in + 1;
			call store_specification (sp_format);
		     end;
		else if ansi77
		then call store_specification (s_format);
		else call skip_line_numbers;
	     end;
	else if char_type = caret
	then do;
		if next_char = "l" | next_char = "L"
		then do;
			in = in + 1;
			call skip_line_numbers;
		     end;
		else goto MISPLACED;
	     end;

/* $-format */

	else if char_type = dollar_format
	then do;
		if dollar_format_location ^= 0
		then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT);

		dollar_format_location = field_count + 1;
		prev_delim = 0;
	     end;

	else if char_type = b_format
	then do;
		if next_char = "z" | next_char = "Z"
		then fmt_spec = bz_format;
		else if next_char = "n" | next_char = "N"
		then fmt_spec = bn_format;
		else goto MISPLACED;
		in = in + 1;
		field_count = field_count + 1;
		call store_specification (fmt_spec);
	     end;
	goto main_loop;

new_action (27):					/* build exponent field */
	digit_encountered = TRUE;
	expon_field = expon_field * 10 + j - ascii_for_zero;
	goto main_loop;

new_action (28):					/* complete e and g formats with expon */
	field_count = field_count + 1;

	if ^digit_encountered
	then call parse_failure ("Missing exponent field.", WITH_CONTEXT);

	if expon_field > max_value
	then call parse_failure ("Exponent field too large.", WITH_CONTEXT);

	call store_specification (fmt_spec);
	goto new_action (action_list (table_column (char_type)));

new_action (29):
	if next_char = "l" | next_char = "L"
	then do;
		in = in + 1;
		fmt_spec = tl_format;
	     end;
	else if next_char = "r" | next_char = "R"
	then do;
		in = in + 1;
		fmt_spec = tr_format;
	     end;
	else fmt_spec = t_format;

	digit_encountered = FALSE;
	r = 1;
	goto main_loop;

new_action (30):					/* prepare for expon field in Ew.dEe formats */
	if char_type = e_format & (fmt_spec = e_format | fmt_spec = g_format)
	then do;
		new_state = 6;			/* build expon field */
		goto process_d_field;
	     end;
	else goto MISPLACED;

successful_return:
	out = out * chars_per_word + 1;		/* Length of spec in chars. Only the first char of the */
						/* final word is included in length. */

/* If called by compiler and hollerith fields exist, copy them into spec. */

	if ^from_runtime
	then do i = first_string repeat p -> long_format.precision while (i ^= 0);
		p = addr (output_format.fmt (i));

		if out + p -> long_format.rep_factor > length (encoded_format) - chars_per_halfword
		then call parse_failure ("Format specification is too long.", WITH_CONTEXT);

		substr (encoded_format, out + 1, p -> long_format.rep_factor) =
		     substr (source_chars, p -> long_format.width, p -> long_format.rep_factor);
		p -> long_format.width = out + 1;
		out = out + p -> long_format.rep_factor;
	     end;

/* Zero remaining character positions in the last word. */

	j = divide (out, chars_per_word, 17, 0);
	i = out - j * chars_per_word;

	if i ^= 0
	then word (j + 1) = word (j + 1) & char_mask (i);


	out = divide (out + chars_per_halfword - 1, chars_per_halfword, 17, 0) * chars_per_halfword;
						/* round to half word */

/* Post processing for v-format. */

	if V_format_location ^= 0
	then do;
		if V_format_location ^= field_count
		then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT);
		output_format.list_directed = TRUE;
		out = chars_per_word;
	     end;

/* Post processing for asterisk-format. */

	else if asterisk_format_location ^= 0
	then do;
		if asterisk_format_location ^= field_count
		then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT);
		output_format.list_directed = TRUE;
		out = chars_per_word;
	     end;

/* Post processing for $-format. */

	if dollar_format_location ^= 0
	then do;
		if dollar_format_location ^= field_count
		then call parse_failure ("$-format must be the last specification in a format specification.",
			NO_CONTEXT);
		output_format.suppress_newline = TRUE;
	     end;


list_directed_return:
	output_format.fmt_len = out;			/* Copy length into format */
	output_ptr -> old_format.fmt (divide (out, chars_per_halfword, 17, 0) - 1) = in + 1;
						/* Return number of chars parsed. */
	error_code = 0;
	return;


abort_return:
	error_code = -1;
	return;

store_specification:
     procedure (a_type);

	dcl     a_type		 fixed bin;
	dcl     word_count		 fixed bin;
	dcl     p			 ptr;
	dcl     spec_type		 fixed bin;

	dcl     fix_bin_17		 fixed bin internal static options (constant) initial (131071);

	if r > fix_bin_17
	then call parse_failure ("Implementation restriction: repetition count must be less than 131072.", WITH_CONTEXT)
		;
	if w > fix_bin_17 | -w > fix_bin_17
	then call parse_failure ("Implementation restriction: field width must be less than 131072.", WITH_CONTEXT);
	if d > fix_bin_17
	then call parse_failure ("Implementation restriction: number of fractional digits must be less than 131072.",
		WITH_CONTEXT);

	spec_type = a_type;

	p = addr (output_format.fmt (out + 1));

/* Use long format for all string fields or if overflow occurs.
   Note: w must always be positive, except for tl_format which is implemented as "negative" tr_format
 */

	if r > max_value | w > max_value | d > max_value | spec_type = hollerith_field | spec_type = quoted_string
	     | expon_field > 0 | -w > max_value
	then do;
		if increment_table (spec_type) <= 2
		then word_count = 1;
		else word_count = 2;

		if out + word_count > hbound (output_format.fmt, 1)
		then call parse_failure ("Format specification is too long.", WITH_CONTEXT);
		else out = out + word_count;

		p -> long_format.spec = spec_type;
		p -> long_format.long_format = TRUE;
		p -> long_format.exponent = expon_field;
		p -> long_format.rep_factor = r;

		if word_count > 1
		then do;
			p -> long_format.width = w;
			p -> long_format.precision = d;
		     end;
	     end;

	else do;
		if out + 1 > hbound (output_format.fmt, 1)
		then call parse_failure ("Format specifiation is too long.", WITH_CONTEXT);
		else out = out + 1;

		p -> format.spec = spec_type;
		p -> format.long_format = FALSE;
		p -> format.rep_factor = r;
		p -> format.width = w;
		p -> format.precision = d;
	     end;

	r, w, d, expon_field, prev_delim = 0;
	minus_encountered, digit_encountered = FALSE;
     end /* store_specification */;

skip_line_numbers:
     procedure;

	declare err_chars		 char (2) varying;

	if field_count ^= 1
	then call parse_failure ("Line number skipping must be the first specification in a format specification.",
		NO_CONTEXT);
	if output_format.skip_line_numbers
	then do;
		if ansi77
		then err_chars = "^N";
		else err_chars = "S";
		call parse_failure (ONLY1 || err_chars || ALLOWED, NO_CONTEXT);
	     end;

	output_format.skip_line_numbers = TRUE;
	prev_delim = 0;
     end skip_line_numbers;

parse_failure:
     procedure (err_str, add_chars);

	dcl     add_chars		 bit (1) aligned;
	dcl     err_str		 char (*);
	dcl     max		 builtin;

/*	This procedure is called to return abnormally from parsing a format specification. */

	i = length (err_str);			/* length of message */
	addr (encoded_format) -> error_message = err_str; /* copy message and blank the rest */

	if add_chars				/* if message is to include context, add it now */
	then do;
		substr (encoded_format, i + 5, 13) = " Context is:
";
		j = max (in - 9, 0);		/* Try to get preceding characters */
		substr (encoded_format, i + 18, in - j + 1) = substr (in_fmt, j + 1, in - j + 1);
	     end;

/* return number of characters parsed */

	addr (encoded_format) -> input_length = in + 1;
	goto abort_return;
     end /* parse_failure */;
     end /* general_format_parse_ */;




		    return_to_user.alm              11/05/86  1557.9r w 11/04/86  1038.6       33894



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

" HISTORY COMMENTS:
"  1) change(86-07-14,BWong), approve(86-07-14,MCR7442),
"     audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105):
"     Fix fortran bug 493.
"                                                      END HISTORY COMMENTS


"	return_to_user.alm
"
"	This module implements end= and err= for fortran_io_. It also implements all returns
"	to the user from fortran_io_. The entry point return_to_user is used to implement
"	end= and err=. The entry point special_return is used to implement a return from
"	fortran_io_ while "absorbing" fortran_io_'s stack frame.
"
"	Written by Richard A. Barnes 18 November 1976.
"
"		Usages:
"
"	declare	return_to_user	entry(ptr, ptr);
"		call return_to_user(return_loc_ptr, stack_frame_ptr);
"
"	declare	return_to_user$special_return		entry;
"		call return_to_user$special_return();
"
"	This module makes the following assumptions:
"	 - no cleanup handlers exist between the user's stack frame and our stack frame,
"	 - the user's stack frame is not extended,
"	 - no rings have been crossed between the user's frame and fortran_io_'s (ours).
"	 - fortran_io_'s stack frame is absorbed by the user frame when fortran_io_ returns.
"	   This is possible only if fortran_io_ always uses return_to_user$special_return
"	   to return to its caller.
"
"
" Modified:
"	11 March 86, MM & BW - 493: Make 'return_to_user' save indicators
"		in sp|stack_frame.return_ptr+1 before returning.  Remove
"		restoring of indicators in 'special_return'.  In both
"		cases, 'short_return' will restore the indicators.
"	07 Dec 83, HH - Make 'special_return' restore indicators before returning.
"	15 March 1978 DSL - fix $return_to_user code.
"	19 Dec 1977 DSL - to implement special_return entry point and modify return_to_user
"		entry point for new stack frame conventions.
"
	include	stack_header
	include	stack_frame

	name	return_to_user
	segdef	return_to_user

return_to_user:
"
"		     First, make user stack frame the current frame and absorb
"		fortran_io_'s stack frame within the user stack frame.
"
	eppbp	ap|4,*			" get address of 2nd argument
	inhibit	on
	eppsp	bp|0,*			" get address of user stack frame into SP
	eppbp	sp|stack_frame.next_sp,*	" get address of fortran_io_ stack frame
	eppbb	bp|4,*			" get true end of fortran_io_ frame
	spribb	bp|stack_frame.next_sp	" restore fortran_io_'s next_sp
	spribb	sp|stack_frame.next_sp	" include fortran_io_ frame within user's
	spribb	sb|stack_header.stack_end_ptr	" shorten stack to end of user's frame
	inhibit	off
"
"		     Next, use first argument to set return ptr.
"
	eppbb	ap|2,*			" get address of 1st argument
	eppbb	bb|0,*			" get value of return_loc_ptr
	ldi	sp|stack_frame.return_ptr+1	" save indicators temporarily
	spribb	sp|stack_frame.return_ptr	" the seg num must be restored
	sti	sp|stack_frame.return_ptr+1	" restore indicators in memory
"
	short_return			" return to user
"
"
"
"	entry point special_return. Coded: 12 Dec 1977 by David Levin.
"
	segdef	special_return

special_return:
	eppbb	sp|stack_frame.next_sp,*	" get address of end of fio stack frame
	inhibit	on
	eppsp	sp|stack_frame.prev_sp,*	" pop back to user frame
	spribb	sp|stack_frame.next_sp	" absorb fortran_io_ stack frame
	inhibit	off
	lreg	sp|8			" load regs stored by pl1_operators_

	short_return			" return to user
	end




		    set_cc.pl1                      12/27/84  0853.8rew 12/27/84  0838.8       27684



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

/* Coded by A. Downing to turn carriage control
   off/on for fortran files. */

/* Modified:
	14 July 1983, Michael Mabey - add the control args: -defer, -no_defer
	22 April 1977, David Levin -change to just act as command interface
		and not attempt to validate its input
*/

/* format: style3,^delnl,linecom */
set_cc:
     proc;

dcl	cu_$arg_count	entry (fixed bin);
dcl	cu_$arg_ptr	entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl	com_err_		entry options (variable);
dcl	error_table_$wrong_no_of_args
			ext static fixed bin (35);
dcl	file_num		fixed bin;
dcl	fortran_io_$set_cc	entry (fixed bin, bit (1) aligned, fixed bin (35));
dcl	fortran_io_$set_cc_defer
			entry (fixed bin, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35));
dcl	arg		char (n) based (argp);
dcl	argp		ptr;
dcl	n		fixed bin;
dcl	i		fixed bin;
dcl	number_of_args	fixed bin;
dcl	cc		bit (1) aligned init ("1"b);
dcl	defer		bit (1) aligned init ("0"b);
dcl	defer_specified	bit (1) aligned init ("0"b);
dcl	code		fixed bin (35);
dcl	(verify, substr)	builtin;

	call cu_$arg_count (number_of_args);			/* get number of args */
	if number_of_args < 2
	then do;
		call com_err_ (error_table_$wrong_no_of_args, "set_cc", "^/Usage: set_cc filenn -control_args");
		return;
	     end;

	call cu_$arg_ptr (1, argp, n, code);		/* Get first one, file name. */
	if code ^= 0
	then do;
		call com_err_ (code, "set_cc");
		return;
	     end;

/* validate it */

	if substr (arg, 1, 4) ^= "file" | verify (substr (arg, 5, 2), "0123456789") ^= 0 | substr (arg, 7) ^= ""
	then do;
		call com_err_ (0, "set_cc", "filenn is filename, where nn is two digit value of file number. ""^a""",
		     arg);
		return;
	     end;

	file_num = convert (file_num, substr (arg, 5));	/* convert to binary */

	do i = 2 to number_of_args;			/* process the remaining arguments */
	     call cu_$arg_ptr (i, argp, n, code);
	     if code ^= 0
	     then do;
		     call com_err_ (code, "set_cc");
		     return;
		end;
	     if arg = "-on"
	     then cc = "1"b;
	     else if arg = "-off"
	     then cc = "0"b;
	     else if arg = "-defer"
	     then defer, defer_specified = "1"b;
	     else if arg = "-no_defer"
	     then do;
		     defer = "0"b;
		     defer_specified = "1"b;
		end;
	     else do;
		     call com_err_ (0, "set_cc", "Valid arguments are: -on; -off; -defer; -no_defer.  Not ""^a"".", arg);
		     return;
		end;
	     end /* of while loop */;

	call fortran_io_$set_cc_defer (file_num, cc, defer, defer_specified, code);
	if code ^= 0
	then call com_err_ (code, "set_cc", "File number ^d", file_num);

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