Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

15 files changed, 10016 insertions, 0 deletions

diff --git a/libgfortran/io/backspace.c b/libgfortran/io/backspace.c
new file mode 100644
index 0000000..7502f1d
--- /dev/null
+++ b/libgfortran/io/backspace.c
@@ -0,0 +1,160 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+/* backspace.c -- Implement the BACKSPACE statement */
+
+/* formatted_backspace(void)-- Move the file back one line.  The
+ * current position is after the newline that terminates the previous
+ * record, and we have to sift backwards to find the newline before
+ * that or the start of the file, whichever comes first. */
+
+#define READ_CHUNK 4096
+
+static void
+formatted_backspace (void)
+{
+  offset_t base;
+  char *p;
+  int n;
+
+  base = file_position (current_unit->s) - 1;
+
+  do
+    {
+      n = (base < READ_CHUNK) ? base : READ_CHUNK;
+      base -= n;
+
+      p = salloc_r_at (current_unit->s, &n, base);
+      if (p == NULL)
+	goto io_error;
+
+      /* Because we've moved backwords from the current position, it
+       * should not be possible to get a short read.  Because it isn't
+       * clear what to do about such thing, we ignore the possibility. */
+
+      /* There is no memrchr() in the C library, so we have to do it
+       * ourselves. */
+
+      n--;
+      while (n >= 0)
+	{
+	  if (p[n] == '\n')
+	    {
+	      base += n + 1;
+	      goto done;
+	    }
+
+	  n--;
+	}
+
+    }
+  while (base != 0);
+
+/* base is the new pointer.  Seek to it exactly */
+
+done:
+  if (sseek (current_unit->s, base) == FAILURE)
+    goto io_error;
+  current_unit->last_record--;
+
+  return;
+
+io_error:
+  generate_error (ERROR_OS, NULL);
+}
+
+
+/* unformatted_backspace()-- Move the file backwards for an
+ * unformatted sequential file.  We are guaranteed to be between
+ * records on entry and we have to shift to the previous record.  */
+
+static void
+unformatted_backspace (void)
+{
+  offset_t *p, new;
+  int length;
+
+  length = sizeof (offset_t);
+
+  p = (offset_t *) salloc_r_at (current_unit->s, &length,
+				file_position (current_unit->s) - length);
+  if (p == NULL)
+    goto io_error;
+
+  new = file_position (current_unit->s) - *p - length;
+  if (sseek (current_unit->s, new) == FAILURE)
+    goto io_error;
+
+  current_unit->last_record--;
+  return;
+
+io_error:
+  generate_error (ERROR_OS, NULL);
+}
+
+
+void
+st_backspace (void)
+{
+  unit_t *u;
+
+  library_start ();
+
+  u = find_unit (ioparm.unit);
+  if (u == NULL)
+    {
+      generate_error (ERROR_BAD_UNIT, NULL);
+      goto done;
+    }
+
+  current_unit = u;
+
+  /* Ignore direct access.  Non-advancing I/O is only allowed for
+   * formatted sequential I/O and the next direct access transfer
+   * repositions the file anyway. */
+
+  if (u->flags.access == ACCESS_DIRECT)
+    goto done;
+
+  /* Check for special cases involving the ENDFILE record first */
+
+  if (u->endfile == AFTER_ENDFILE)
+    u->endfile = AT_ENDFILE;
+  else
+    {
+      if (u->current_record)
+	next_record (1);
+
+      if (file_position (u->s) == 0)
+	goto done;		/* Common special case */
+
+      if (u->flags.form == FORM_UNFORMATTED)
+	formatted_backspace ();
+      else
+	unformatted_backspace ();
+    }
+
+done:
+  library_end ();
+}
diff --git a/libgfortran/io/close.c b/libgfortran/io/close.c
new file mode 100644
index 0000000..9e2a5a3
--- /dev/null
+++ b/libgfortran/io/close.c
@@ -0,0 +1,70 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+typedef enum
+{ CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED }
+close_status;
+
+static st_option status_opt[] = {
+  {"keep", CLOSE_KEEP},
+  {"delete", CLOSE_DELETE},
+  {NULL}
+};
+
+
+void
+st_close (void)
+{
+  close_status status;
+  unit_t *u;
+
+  library_start ();
+
+  status = (ioparm.status == NULL) ? CLOSE_UNSPECIFIED :
+    find_option (ioparm.status, ioparm.status_len, status_opt,
+		 "Bad STATUS parameter in CLOSE statement");
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  u = find_unit (ioparm.unit);
+  if (u != NULL)
+    {
+      if (u->flags.status == STATUS_SCRATCH)
+	{
+	  if (status == CLOSE_KEEP)
+	    generate_error (ERROR_BAD_OPTION,
+			    "Can't KEEP a scratch file on CLOSE");
+	}
+      else
+	{
+	  if (status == CLOSE_DELETE)
+	    delete_file (u);
+	}
+
+      close_unit (u);
+    }
+
+  library_end ();
+}
diff --git a/libgfortran/io/endfile.c b/libgfortran/io/endfile.c
new file mode 100644
index 0000000..56f81f0
--- /dev/null
+++ b/libgfortran/io/endfile.c
@@ -0,0 +1,46 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+/* endfile.c--  Implement the ENDFILE statement */
+
+void
+st_endfile (void)
+{
+  unit_t *u;
+
+  library_start ();
+
+  u = get_unit (0);
+  if (u != NULL)
+    {
+      current_unit = u;		/* next_record() needs this set */
+      if (u->current_record)
+	next_record (1);
+
+      struncate (u->s);
+      u->endfile = AFTER_ENDFILE;
+    }
+
+  library_end ();
+}
diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c
new file mode 100644
index 0000000..caec167
--- /dev/null
+++ b/libgfortran/io/format.c
@@ -0,0 +1,1285 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+/* format.c-- parse a FORMAT string into a binary format suitable for
+ * interpretation during I/O statements */
+
+#include "config.h"
+#include <ctype.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+
+/* Number of format nodes that we can store statically before we have
+ * to resort to dynamic allocation.  The root node is array[0]. */
+
+#define FARRAY_SIZE 200
+
+static fnode *avail, array[FARRAY_SIZE];
+
+/* Local variables for checking format strings.  The saved_token is
+ * used to back up by a single format token during the parsing process. */
+
+static char *format_string, *string;
+static const char *error;
+static format_token saved_token;
+static int value, format_string_len, reversion_ok;
+
+static fnode *saved_format, colon_node = { FMT_COLON };
+
+/* Error messages */
+
+static char posint_required[] = "Positive width required in format",
+  period_required[] = "Period required in format",
+  nonneg_required[] = "Nonnegative width required in format",
+  unexpected_element[] = "Unexpected element in format",
+  unexpected_end[] = "Unexpected end of format string",
+  bad_string[] = "Unterminated character constant in format",
+  bad_hollerith[] = "Hollerith constant extends past the end of the format",
+  reversion_error[] = "Exhausted data descriptors in format";
+
+
+/* next_char()-- Return the next character in the format string.
+ * Returns -1 when the string is done.  If the literal flag is set,
+ * spaces are significant, otherwise they are not. */
+
+static int
+next_char (int literal)
+{
+  int c;
+
+  do
+    {
+      if (format_string_len == 0)
+	return -1;
+
+      format_string_len--;
+      c = toupper (*format_string++);
+    }
+  while (c == ' ' && !literal);
+
+  return c;
+}
+
+
+/* unget_char()-- Back up one character position. */
+
+#define unget_char() { format_string--;  format_string_len++; }
+
+
+/* get_fnode()-- Allocate a new format node, inserting it into the
+ * current singly linked list.  These are initially allocated from the
+ * static buffer. */
+
+static fnode *
+get_fnode (fnode ** head, fnode ** tail, format_token t)
+{
+  fnode *f;
+
+  if (avail - array >= FARRAY_SIZE)
+    f = get_mem (sizeof (fnode));
+  else
+    {
+      f = avail++;
+      memset (f, '\0', sizeof (fnode));
+    }
+
+  if (*head == NULL)
+    *head = *tail = f;
+  else
+    {
+      (*tail)->next = f;
+      *tail = f;
+    }
+
+  f->format = t;
+  f->repeat = -1;
+  f->source = format_string;
+  return f;
+}
+
+
+/* free_fnode()-- Recursive function to free the given fnode and
+ * everything it points to.  We only have to actually free something
+ * if it is outside of the static array. */
+
+static void
+free_fnode (fnode * f)
+{
+  fnode *next;
+
+  for (; f; f = next)
+    {
+      next = f->next;
+
+      if (f->format == FMT_LPAREN)
+	free_fnode (f->u.child);
+      if (f < array || f >= array + FARRAY_SIZE)
+	free_mem (f);
+    }
+}
+
+
+/* free_fnodes()-- Free the current tree of fnodes.  We only have to
+ * traverse the tree if some nodes were allocated dynamically. */
+
+void
+free_fnodes (void)
+{
+
+  if (avail - array >= FARRAY_SIZE)
+    free_fnode (&array[0]);
+
+  avail = array;
+  memset(array, 0, sizeof(avail[0]) * FARRAY_SIZE);
+}
+
+
+/* format_lex()-- Simple lexical analyzer for getting the next token
+ * in a FORMAT string.  We support a one-level token pushback in the
+ * saved_token variable. */
+
+static format_token
+format_lex (void)
+{
+  format_token token;
+  int negative_flag;
+  char c, delim;
+
+  if (saved_token != FMT_NONE)
+    {
+      token = saved_token;
+      saved_token = FMT_NONE;
+      return token;
+    }
+
+  negative_flag = 0;
+  c = next_char (0);
+
+  switch (c)
+    {
+    case '-':
+      negative_flag = 1;
+      /* Fall Through */
+
+    case '+':
+      c = next_char (0);
+      if (!isdigit (c))
+	{
+	  token = FMT_UNKNOWN;
+	  break;
+	}
+
+      value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (0);
+	  if (!isdigit (c))
+	    break;
+
+	  value = 10 * value + c - '0';
+	}
+
+      unget_char ();
+
+      if (negative_flag)
+	value = -value;
+      token = FMT_SIGNED_INT;
+      break;
+
+    case '0':
+    case '1':
+    case '2':
+    case '3':
+    case '4':
+    case '5':
+    case '6':
+    case '7':
+    case '8':
+    case '9':
+      value = c - '0';
+
+      for (;;)
+	{
+	  c = next_char (0);
+	  if (!isdigit (c))
+	    break;
+
+	  value = 10 * value + c - '0';
+	}
+
+      unget_char ();
+      token = (value == 0) ? FMT_ZERO : FMT_POSINT;
+      break;
+
+    case '.':
+      token = FMT_PERIOD;
+      break;
+
+    case ',':
+      token = FMT_COMMA;
+      break;
+
+    case ':':
+      token = FMT_COLON;
+      break;
+
+    case '/':
+      token = FMT_SLASH;
+      break;
+
+    case '$':
+      token = FMT_DOLLAR;
+      break;
+
+    case 'T':
+      switch (next_char (0))
+	{
+	case 'L':
+	  token = FMT_TL;
+	  break;
+	case 'R':
+	  token = FMT_TR;
+	  break;
+	default:
+	  token = FMT_T;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case '(':
+      token = FMT_LPAREN;
+      break;
+
+    case ')':
+      token = FMT_RPAREN;
+      break;
+
+    case 'X':
+      token = FMT_X;
+      break;
+
+    case 'S':
+      switch (next_char (0))
+	{
+	case 'S':
+	  token = FMT_SS;
+	  break;
+	case 'P':
+	  token = FMT_SP;
+	  break;
+	default:
+	  token = FMT_S;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case 'B':
+      switch (next_char (0))
+	{
+	case 'N':
+	  token = FMT_BN;
+	  break;
+	case 'Z':
+	  token = FMT_BZ;
+	  break;
+	default:
+	  token = FMT_B;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case '\'':
+    case '"':
+      delim = c;
+
+      string = format_string;
+      value = 0;		/* This is the length of the string */
+
+      for (;;)
+	{
+	  c = next_char (1);
+	  if (c == -1)
+	    {
+	      token = FMT_BADSTRING;
+	      error = bad_string;
+	      break;
+	    }
+
+	  if (c == delim)
+	    {
+	      c = next_char (1);
+
+	      if (c == -1)
+		{
+		  token = FMT_BADSTRING;
+		  error = bad_string;
+		  break;
+		}
+
+	      if (c != delim)
+		{
+		  unget_char ();
+		  token = FMT_STRING;
+		  break;
+		}
+	    }
+
+	  value++;
+	}
+
+      break;
+
+    case 'P':
+      token = FMT_P;
+      break;
+
+    case 'I':
+      token = FMT_I;
+      break;
+
+    case 'O':
+      token = FMT_O;
+      break;
+
+    case 'Z':
+      token = FMT_Z;
+      break;
+
+    case 'F':
+      token = FMT_F;
+      break;
+
+    case 'E':
+      switch (next_char (0))
+	{
+	case 'N':
+	  token = FMT_EN;
+	  break;
+	case 'S':
+	  token = FMT_ES;
+	  break;
+	default:
+	  token = FMT_E;
+	  unget_char ();
+	  break;
+	}
+
+      break;
+
+    case 'G':
+      token = FMT_G;
+      break;
+
+    case 'H':
+      token = FMT_H;
+      break;
+
+    case 'L':
+      token = FMT_L;
+      break;
+
+    case 'A':
+      token = FMT_A;
+      break;
+
+    case 'D':
+      token = FMT_D;
+      break;
+
+    case -1:
+      token = FMT_END;
+      break;
+
+    default:
+      token = FMT_UNKNOWN;
+      break;
+    }
+
+  return token;
+}
+
+
+/* parse_format_list()-- Parse a format list.  Assumes that a left
+ * paren has already been seen.  Returns a list representing the
+ * parenthesis node which contains the rest of the list. */
+
+static fnode *
+parse_format_list (void)
+{
+  fnode *head, *tail;
+  format_token t, u, t2;
+  int repeat;
+
+  head = tail = NULL;
+
+/* Get the next format item */
+
+format_item:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_POSINT:
+      repeat = value;
+
+      t = format_lex ();
+      switch (t)
+	{
+	case FMT_LPAREN:
+	  get_fnode (&head, &tail, FMT_LPAREN);
+	  tail->repeat = repeat;
+	  tail->u.child = parse_format_list ();
+	  if (error != NULL)
+	    goto finished;
+
+	  goto between_desc;
+
+	case FMT_SLASH:
+	  get_fnode (&head, &tail, FMT_SLASH);
+	  tail->repeat = repeat;
+	  goto optional_comma;
+
+	case FMT_X:
+	  get_fnode (&head, &tail, FMT_X);
+	  tail->repeat = 1;
+	  tail->u.k = value;
+	  goto between_desc;
+
+	case FMT_P:
+	  goto p_descriptor;
+
+	default:
+	  goto data_desc;
+	}
+
+    case FMT_LPAREN:
+      get_fnode (&head, &tail, FMT_LPAREN);
+      tail->repeat = 1;
+      tail->u.child = parse_format_list ();
+      if (error != NULL)
+	goto finished;
+
+      goto between_desc;
+
+    case FMT_SIGNED_INT:	/* Signed integer can only precede a P format.  */
+    case FMT_ZERO:		/* Same for zero.  */
+      t = format_lex ();
+      if (t != FMT_P)
+	{
+	  error = "Expected P edit descriptor in format";
+	  goto finished;
+	}
+
+    p_descriptor:
+      get_fnode (&head, &tail, FMT_P);
+      tail->u.k = value;
+
+      t = format_lex ();
+      if (t == FMT_F || t == FMT_EN || t == FMT_ES || t == FMT_D
+	  || t == FMT_G || t == FMT_E)
+	{
+	  repeat = 1;
+	  goto data_desc;
+	}
+
+      saved_token = t;
+      goto between_desc;
+
+    case FMT_P:		/* P and X require a prior number */
+      error = "P descriptor requires leading scale factor";
+      goto finished;
+
+    case FMT_X:
+/*
+   EXTENSION!
+
+   If we would be pedantic in the library, we would have to reject
+   an X descriptor without an integer prefix:
+
+      error = "X descriptor requires leading space count";
+      goto finished;
+
+   However, this is an extension supported by many Fortran compilers,
+   including Cray, HP, AIX, and IRIX.  Therefore, we allow it in the
+   runtime library, and make the front end reject it if the compiler
+   is in pedantic mode.  The interpretation of 'X' is '1X'.
+*/
+      get_fnode (&head, &tail, FMT_X);
+      tail->repeat = 1;
+      tail->u.k = 1;
+      goto between_desc;
+
+    case FMT_STRING:
+      get_fnode (&head, &tail, FMT_STRING);
+
+      tail->u.string.p = string;
+      tail->u.string.length = value;
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_S:
+    case FMT_SS:
+    case FMT_SP:
+    case FMT_BN:
+    case FMT_BZ:
+      get_fnode (&head, &tail, t);
+      goto between_desc;
+
+    case FMT_COLON:
+      get_fnode (&head, &tail, FMT_COLON);
+      goto optional_comma;
+
+    case FMT_SLASH:
+      get_fnode (&head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+      tail->u.r = 1;
+      goto optional_comma;
+
+    case FMT_DOLLAR:
+      get_fnode (&head, &tail, FMT_DOLLAR);
+      goto between_desc;
+
+    case FMT_T:
+    case FMT_TL:
+    case FMT_TR:
+      t2 = format_lex ();
+      if (t2 != FMT_POSINT)
+	{
+	  error = posint_required;
+	  goto finished;
+	}
+      get_fnode (&head, &tail, t);
+      tail->u.n = value;
+      tail->repeat = 1;
+      goto between_desc;
+
+    case FMT_I:
+    case FMT_B:
+    case FMT_O:
+    case FMT_Z:
+    case FMT_E:
+    case FMT_EN:
+    case FMT_ES:
+    case FMT_D:
+    case FMT_L:
+    case FMT_A:
+    case FMT_F:
+    case FMT_G:
+      repeat = 1;
+      goto data_desc;
+
+    case FMT_H:
+      get_fnode (&head, &tail, FMT_STRING);
+
+      if (format_string_len < 1)
+	{
+	  error = bad_hollerith;
+	  goto finished;
+	}
+
+      tail->u.string.p = format_string;
+      tail->u.string.length = 1;
+      tail->repeat = 1;
+
+      format_string++;
+      format_string_len--;
+
+      goto between_desc;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto finished;
+
+    case FMT_BADSTRING:
+      goto finished;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:
+      error = unexpected_element;
+      goto finished;
+    }
+
+/* In this state, t must currently be a data descriptor.  Deal with
+ * things that can/must follow the descriptor */
+
+data_desc:
+  switch (t)
+    {
+    case FMT_P:
+      t = format_lex ();
+      if (t == FMT_POSINT)
+	{
+	  error = "Repeat count cannot follow P descriptor";
+	  goto finished;
+	}
+
+      saved_token = t;
+      get_fnode (&head, &tail, FMT_P);
+
+      goto optional_comma;
+
+    case FMT_L:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+	{
+	  error = posint_required;
+	  goto finished;
+	}
+
+      get_fnode (&head, &tail, FMT_L);
+      tail->u.n = value;
+      tail->repeat = repeat;
+      break;
+
+    case FMT_A:
+      t = format_lex ();
+      if (t != FMT_POSINT)
+	{
+	  saved_token = t;
+	  value = -1;		/* Width not present */
+	}
+
+      get_fnode (&head, &tail, FMT_A);
+      tail->repeat = repeat;
+      tail->u.n = value;
+      break;
+
+    case FMT_D:
+    case FMT_E:
+    case FMT_F:
+    case FMT_G:
+    case FMT_EN:
+    case FMT_ES:
+      get_fnode (&head, &tail, t);
+      tail->repeat = repeat;
+
+      u = format_lex ();
+      if (t == FMT_F || g.mode == WRITING)
+	{
+	  if (u != FMT_POSINT && u != FMT_ZERO)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (u != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.real.w = value;
+      t2 = t;
+      t = format_lex ();
+      if (t != FMT_PERIOD)
+	{
+	  error = period_required;
+	  goto finished;
+	}
+
+      t = format_lex ();
+      if (t != FMT_ZERO && t != FMT_POSINT)
+	{
+	  error = nonneg_required;
+	  goto finished;
+	}
+
+      tail->u.real.d = value;
+
+      if (t == FMT_D || t == FMT_F)
+	break;
+
+      tail->u.real.e = -1;
+
+/* Look for optional exponent */
+
+      t = format_lex ();
+      if (t != FMT_E)
+	saved_token = t;
+      else
+	{
+	  t = format_lex ();
+	  if (t != FMT_POSINT)
+	    {
+	      error = "Positive exponent width required in format";
+	      goto finished;
+	    }
+
+	  tail->u.real.e = value;
+	}
+
+      break;
+
+    case FMT_H:
+      if (repeat > format_string_len)
+	{
+	  error = bad_hollerith;
+	  goto finished;
+	}
+
+      get_fnode (&head, &tail, FMT_STRING);
+
+      tail->u.string.p = format_string;
+      tail->u.string.length = repeat;
+      tail->repeat = 1;
+
+      format_string += value;
+      format_string_len -= repeat;
+
+      break;
+
+    case FMT_I:
+    case FMT_B:
+    case FMT_O:
+    case FMT_Z:
+      get_fnode (&head, &tail, t);
+      tail->repeat = repeat;
+
+      t = format_lex ();
+
+      if (g.mode == READING)
+	{
+	  if (t != FMT_POSINT)
+	    {
+	      error = posint_required;
+	      goto finished;
+	    }
+	}
+      else
+	{
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+	}
+
+      tail->u.integer.w = value;
+      tail->u.integer.m = -1;
+
+      t = format_lex ();
+      if (t != FMT_PERIOD)
+	{
+	  saved_token = t;
+	}
+      else
+	{
+	  t = format_lex ();
+	  if (t != FMT_ZERO && t != FMT_POSINT)
+	    {
+	      error = nonneg_required;
+	      goto finished;
+	    }
+
+	  tail->u.integer.m = value;
+	}
+
+      if (tail->u.integer.w != 0 && tail->u.integer.m > tail->u.integer.w)
+	{
+	  error = "Minimum digits exceeds field width";
+	  goto finished;
+	}
+
+      break;
+
+    default:
+      error = unexpected_element;
+      goto finished;
+    }
+
+/* Between a descriptor and what comes next */
+between_desc:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_COMMA:
+      goto format_item;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    case FMT_SLASH:
+      get_fnode (&head, &tail, FMT_SLASH);
+      tail->repeat = 1;
+
+      /* Fall Through */
+
+    case FMT_COLON:
+      goto optional_comma;
+
+    case FMT_END:
+      error = unexpected_end;
+      goto finished;
+
+    default:
+      error = "Missing comma in format";
+      goto finished;
+    }
+
+/* Optional comma is a weird between state where we've just finished
+ * reading a colon, slash or P descriptor. */
+
+optional_comma:
+  t = format_lex ();
+  switch (t)
+    {
+    case FMT_COMMA:
+      break;
+
+    case FMT_RPAREN:
+      goto finished;
+
+    default:			/* Assume that we have another format item */
+      saved_token = t;
+      break;
+    }
+
+  goto format_item;
+
+finished:
+  return head;
+}
+
+
+/* format_error()-- Generate an error message for a format statement.
+ * If the node that gives the location of the error is NULL, the error
+ * is assumed to happen at parse time, and the current location of the
+ * parser is shown.
+ *
+ * After freeing any dynamically allocated fnodes, generate a message
+ * showing where the problem is.  We take extra care to print only the
+ * relevant part of the format if it is longer than a standard 80
+ * column display. */
+
+void
+format_error (fnode * f, const char *message)
+{
+  int width, i, j, offset;
+  char *p, buffer[300];
+
+  if (f != NULL)
+    format_string = f->source;
+
+  free_fnodes ();
+
+  st_sprintf (buffer, "%s\n", message);
+
+  j = format_string - ioparm.format;
+
+  offset = (j > 60) ? j - 40 : 0;
+
+  j -= offset;
+  width = ioparm.format_len - offset;
+
+  if (width > 80)
+    width = 80;
+
+  /* Show the format */
+
+  p = strchr (buffer, '\0');
+
+  memcpy (p, ioparm.format + offset, width);
+
+  p += width;
+  *p++ = '\n';
+
+  /* Show where the problem is */
+
+  for (i = 1; i < j; i++)
+    *p++ = ' ';
+
+  *p++ = '^';
+  *p = '\0';
+
+  generate_error (ERROR_FORMAT, buffer);
+}
+
+
+/* parse_format()-- Parse a format string.  */
+
+void
+parse_format (void)
+{
+
+  format_string = ioparm.format;
+  format_string_len = ioparm.format_len;
+
+  saved_token = FMT_NONE;
+  error = NULL;
+
+/* Initialize variables used during traversal of the tree */
+
+  reversion_ok = 0;
+  g.reversion_flag = 0;
+  saved_format = NULL;
+
+/* Allocate the first format node as the root of the tree */
+
+  avail = array;
+
+  avail->format = FMT_LPAREN;
+  avail->repeat = 1;
+  avail++;
+
+  if (format_lex () == FMT_LPAREN)
+    array[0].u.child = parse_format_list ();
+  else
+    error = "Missing initial left parenthesis in format";
+
+  if (error)
+    format_error (NULL, error);
+}
+
+
+/* revert()-- Do reversion of the format.  Control reverts to the left
+ * parenthesis that matches the rightmost right parenthesis.  From our
+ * tree structure, we are looking for the rightmost parenthesis node
+ * at the second level, the first level always being a single
+ * parenthesis node.  If this node doesn't exit, we use the top
+ * level. */
+
+static void
+revert (void)
+{
+  fnode *f, *r;
+
+  g.reversion_flag = 1;
+
+  r = NULL;
+
+  for (f = array[0].u.child; f; f = f->next)
+    if (f->format == FMT_LPAREN)
+      r = f;
+
+  /* If r is NULL because no node was found, the whole tree will be used */
+
+  array[0].current = r;
+  array[0].count = 0;
+}
+
+
+/* next_format0()-- Get the next format node without worrying about
+ * reversion.  Returns NULL when we hit the end of the list.
+ * Parenthesis nodes are incremented after the list has been
+ * exhausted, other nodes are incremented before they are returned. */
+
+static fnode *
+next_format0 (fnode * f)
+{
+  fnode *r;
+
+  if (f == NULL)
+    return NULL;
+
+  if (f->format != FMT_LPAREN)
+    {
+      f->count++;
+      if (f->count <= f->repeat)
+	return f;
+
+      f->count = 0;
+      return NULL;
+    }
+
+  /* Deal with a parenthesis node */
+
+  for (; f->count < f->repeat; f->count++)
+    {
+      if (f->current == NULL)
+	f->current = f->u.child;
+
+      for (; f->current != NULL; f->current = f->current->next)
+	{
+	  r = next_format0 (f->current);
+	  if (r != NULL)
+	    return r;
+	}
+    }
+
+  f->count = 0;
+  return NULL;
+}
+
+
+/* next_format()-- Return the next format node.  If the format list
+ * ends up being exhausted, we do reversion.  Reversion is only
+ * allowed if the we've seen a data descriptor since the
+ * initialization or the last reversion.  We return NULL if the there
+ * are no more data descriptors to return (which is an error
+ * condition). */
+
+fnode *
+next_format (void)
+{
+  format_token t;
+  fnode *f;
+
+  if (saved_format != NULL)
+    {				/* Deal with a pushed-back format node */
+      f = saved_format;
+      saved_format = NULL;
+      goto done;
+    }
+
+  f = next_format0 (&array[0]);
+  if (f == NULL)
+    {
+      if (!reversion_ok)
+	{
+	  return NULL;
+	}
+
+      reversion_ok = 0;
+      revert ();
+
+      f = next_format0 (&array[0]);
+      if (f == NULL)
+	{
+	  format_error (NULL, reversion_error);
+	  return NULL;
+	}
+
+      /* Push the first reverted token and return a colon node in case
+       * there are no more data items. */
+
+      saved_format = f;
+      return &colon_node;
+    }
+
+  /* If this is a data edit descriptor, then reversion has become OK. */
+
+done:
+  t = f->format;
+
+  if (!reversion_ok &&
+      (t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
+       t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
+       t == FMT_A || t == FMT_D))
+    reversion_ok = 1;
+  return f;
+}
+
+
+/* unget_format()-- Push the given format back so that it will be
+ * returned on the next call to next_format() without affecting
+ * counts.  This is necessary when we've encountered a data
+ * descriptor, but don't know what the data item is yet.  The format
+ * node is pushed back, and we return control to the main program,
+ * which calls the library back with the data item (or not). */
+
+void
+unget_format (fnode * f)
+{
+
+  saved_format = f;
+}
+
+
+
+
+#if 0
+
+static void dump_format1 (fnode * f);
+
+/* dump_format0()-- Dump a single format node */
+
+void
+dump_format0 (fnode * f)
+{
+  char *p;
+  int i;
+
+  switch (f->format)
+    {
+    case FMT_COLON:
+      st_printf (" :");
+      break;
+    case FMT_SLASH:
+      st_printf (" %d/", f->u.r);
+      break;
+    case FMT_DOLLAR:
+      st_printf (" $");
+      break;
+    case FMT_T:
+      st_printf (" T%d", f->u.n);
+      break;
+    case FMT_TR:
+      st_printf (" TR%d", f->u.n);
+      break;
+    case FMT_TL:
+      st_printf (" TL%d", f->u.n);
+      break;
+    case FMT_X:
+      st_printf (" %dX", f->u.n);
+      break;
+    case FMT_S:
+      st_printf (" S");
+      break;
+    case FMT_SS:
+      st_printf (" SS");
+      break;
+    case FMT_SP:
+      st_printf (" SP");
+      break;
+
+    case FMT_LPAREN:
+      if (f->repeat == 1)
+	st_printf (" (");
+      else
+	st_printf (" %d(", f->repeat);
+
+      dump_format1 (f->u.child);
+      st_printf (" )");
+      break;
+
+    case FMT_STRING:
+      st_printf (" '");
+      p = f->u.string.p;
+      for (i = f->u.string.length; i > 0; i--)
+	st_printf ("%c", *p++);
+
+      st_printf ("'");
+      break;
+
+    case FMT_P:
+      st_printf (" %dP", f->u.k);
+      break;
+    case FMT_I:
+      st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_B:
+      st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_O:
+      st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_Z:
+      st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
+      break;
+
+    case FMT_BN:
+      st_printf (" BN");
+      break;
+    case FMT_BZ:
+      st_printf (" BZ");
+      break;
+    case FMT_D:
+      st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
+      break;
+
+    case FMT_EN:
+      st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_ES:
+      st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_F:
+      st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
+      break;
+
+    case FMT_E:
+      st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_G:
+      st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
+		 f->u.real.e);
+      break;
+
+    case FMT_L:
+      st_printf (" %dL%d", f->repeat, f->u.w);
+      break;
+    case FMT_A:
+      st_printf (" %dA%d", f->repeat, f->u.w);
+      break;
+
+    default:
+      st_printf (" ???");
+      break;
+    }
+}
+
+
+/* dump_format1()-- Dump a string of format nodes */
+
+static void
+dump_format1 (fnode * f)
+{
+
+  for (; f; f = f->next)
+    dump_format1 (f);
+}
+
+/* dump_format()-- Dump the whole format node tree */
+
+void
+dump_format (void)
+{
+
+  st_printf ("format = ");
+  dump_format0 (&array[0]);
+  st_printf ("\n");
+}
+
+
+void
+next_test (void)
+{
+  fnode *f;
+  int i;
+
+  for (i = 0; i < 20; i++)
+    {
+      f = next_format ();
+      if (f == NULL)
+	{
+	  st_printf ("No format!\n");
+	  break;
+	}
+
+      dump_format1 (f);
+      st_printf ("\n");
+    }
+}
+
+#endif
diff --git a/libgfortran/io/inquire.c b/libgfortran/io/inquire.c
new file mode 100644
index 0000000..88e805e
--- /dev/null
+++ b/libgfortran/io/inquire.c
@@ -0,0 +1,371 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+/* Implement the non-IOLENGTH variant of the INQUIRY statement */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+
+static char undefined[] = "UNDEFINED";
+
+
+/* inquire_via_unit()-- Inquiry via unit number.  The unit might not exist. */
+
+static void
+inquire_via_unit (unit_t * u)
+{
+  const char *p;
+
+  if (ioparm.exist != NULL)
+    *ioparm.exist = (u != NULL);
+
+  if (ioparm.opened != NULL)
+    *ioparm.opened = (u != NULL);
+
+  if (ioparm.number != NULL)
+    *ioparm.number = (u != NULL) ? u->unit_number : -1;
+
+  if (ioparm.named != NULL)
+    *ioparm.named = (u != NULL && u->flags.status != STATUS_SCRATCH);
+
+  if (ioparm.name != NULL && u != NULL && u->flags.status != STATUS_SCRATCH)
+    fstrcpy (ioparm.name, ioparm.name_len, u->file, u->file_len);
+
+  if (ioparm.access != NULL)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.access)
+	  {
+	  case ACCESS_SEQUENTIAL:
+	    p = "SEQUENTIAL";
+	    break;
+	  case ACCESS_DIRECT:
+	    p = "DIRECT";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad access");
+	  }
+
+      cf_strcpy (ioparm.access, ioparm.access_len, p);
+    }
+
+  if (ioparm.sequential != NULL)
+    {
+      p = (u == NULL) ? inquire_sequential (NULL, 0) :
+	inquire_sequential (u->file, u->file_len);
+
+      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+    }
+
+  if (ioparm.direct != NULL)
+    {
+      p = (u == NULL) ? inquire_direct (NULL, 0) :
+	inquire_direct (u->file, u->file_len);
+
+      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+    }
+
+  if (ioparm.form != NULL)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.form)
+	  {
+	  case FORM_FORMATTED:
+	    p = "FORMATTED";
+	    break;
+	  case FORM_UNFORMATTED:
+	    p = "UNFORMATTED";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad form");
+	  }
+
+      cf_strcpy (ioparm.form, ioparm.form_len, p);
+    }
+
+  if (ioparm.formatted != NULL)
+    {
+      p = (u == NULL) ? inquire_formatted (NULL, 0) :
+	inquire_formatted (u->file, u->file_len);
+
+      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+    }
+
+  if (ioparm.unformatted != NULL)
+    {
+      p = (u == NULL) ? inquire_unformatted (NULL, 0) :
+	inquire_unformatted (u->file, u->file_len);
+
+      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+    }
+
+  if (ioparm.recl_out != NULL)
+    *ioparm.recl_out = (u != NULL) ? u->recl : 0;
+
+  if (ioparm.nextrec != NULL)
+    *ioparm.nextrec = (u != NULL) ? u->last_record + 1 : 0;
+
+  if (ioparm.blank != NULL)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.blank)
+	  {
+	  case BLANK_NULL:
+          p = "NULL";
+	    break;
+	  case BLANK_ZERO:
+	    p = "ZERO";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad blank");
+	  }
+
+      cf_strcpy (ioparm.blank, ioparm.blank_len, p);
+    }
+
+  if (ioparm.position != NULL)
+    {
+      if (u == NULL || u->flags.access == ACCESS_DIRECT)
+	p = undefined;
+      else
+	{
+	  p = NULL;		/* TODO: Try to decode what the standard says... */
+	}
+
+      cf_strcpy (ioparm.blank, ioparm.blank_len, p);
+    }
+
+  if (ioparm.action != NULL)
+    {
+      if (u == NULL)
+	p = undefined;
+      else
+	switch (u->flags.action)
+	  {
+	  case ACTION_READ:
+	    p = "READ";
+	    break;
+	  case ACTION_WRITE:
+	    p = "WRITE";
+	    break;
+	  case ACTION_READWRITE:
+	    p = "READWRITE";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad action");
+	  }
+
+      cf_strcpy (ioparm.action, ioparm.action_len, p);
+    }
+
+  if (ioparm.read != NULL)
+    {
+      p = (u == NULL) ? inquire_read (NULL, 0) :
+	inquire_read (u->file, u->file_len);
+
+      cf_strcpy (ioparm.read, ioparm.read_len, p);
+    }
+
+  if (ioparm.write != NULL)
+    {
+      p = (u == NULL) ? inquire_write (NULL, 0) :
+	inquire_write (u->file, u->file_len);
+
+      cf_strcpy (ioparm.write, ioparm.write_len, p);
+    }
+
+  if (ioparm.readwrite != NULL)
+    {
+      p = (u == NULL) ? inquire_readwrite (NULL, 0) :
+	inquire_readwrite (u->file, u->file_len);
+
+      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+    }
+
+  if (ioparm.delim != NULL)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.delim)
+	  {
+	  case DELIM_NONE:
+	    p = "NONE";
+	    break;
+	  case DELIM_QUOTE:
+	    p = "QUOTE";
+	    break;
+	  case DELIM_APOSTROPHE:
+	    p = "APOSTROPHE";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad delim");
+	  }
+
+      cf_strcpy (ioparm.access, ioparm.access_len, p);
+    }
+
+  if (ioparm.pad != NULL)
+    {
+      if (u == NULL || u->flags.form != FORM_FORMATTED)
+	p = undefined;
+      else
+	switch (u->flags.pad)
+	  {
+	  case PAD_NO:
+	    p = "NO";
+	    break;
+	  case PAD_YES:
+	    p = "YES";
+	    break;
+	  default:
+	    internal_error ("inquire_via_unit(): Bad pad");
+	  }
+
+      cf_strcpy (ioparm.pad, ioparm.pad_len, p);
+    }
+}
+
+
+/* inquire_via_filename()-- Inquiry via filename.  This subroutine is
+ * only used if the filename is *not* connected to a unit number. */
+
+static void
+inquire_via_filename (void)
+{
+  const char *p;
+
+  if (ioparm.exist != NULL)
+    *ioparm.exist = file_exists ();
+
+  if (ioparm.opened != NULL)
+    *ioparm.opened = 0;
+
+  if (ioparm.number != NULL)
+    *ioparm.number = -1;
+
+  if (ioparm.named != NULL)
+    *ioparm.named = 1;
+
+  if (ioparm.name != NULL)
+    fstrcpy (ioparm.name, ioparm.name_len, ioparm.file, ioparm.file_len);
+
+  if (ioparm.access != NULL)
+    cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+
+  if (ioparm.sequential != NULL)
+    {
+      p = inquire_sequential (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.sequential, ioparm.sequential_len, p);
+    }
+
+  if (ioparm.direct != NULL)
+    {
+      p = inquire_direct (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.direct, ioparm.direct_len, p);
+    }
+
+  if (ioparm.form != NULL)
+    cf_strcpy (ioparm.form, ioparm.form_len, undefined);
+
+  if (ioparm.formatted != NULL)
+    {
+      p = inquire_formatted (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.formatted, ioparm.formatted_len, p);
+    }
+
+  if (ioparm.unformatted != NULL)
+    {
+      p = inquire_unformatted (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.unformatted, ioparm.unformatted_len, p);
+    }
+
+  if (ioparm.recl_out != NULL)
+    *ioparm.recl_out = 0;
+
+  if (ioparm.nextrec != NULL)
+    *ioparm.nextrec = 0;
+
+  if (ioparm.blank != NULL)
+    cf_strcpy (ioparm.blank, ioparm.blank_len, undefined);
+
+  if (ioparm.position != NULL)
+    cf_strcpy (ioparm.position, ioparm.position_len, undefined);
+
+  if (ioparm.access != NULL)
+    cf_strcpy (ioparm.access, ioparm.access_len, undefined);
+
+  if (ioparm.read != NULL)
+    {
+      p = inquire_read (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.read, ioparm.read_len, p);
+    }
+
+  if (ioparm.write != NULL)
+    {
+      p = inquire_write (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.write, ioparm.write_len, p);
+    }
+
+  if (ioparm.readwrite != NULL)
+    {
+      p = inquire_read (ioparm.file, ioparm.file_len);
+      cf_strcpy (ioparm.readwrite, ioparm.readwrite_len, p);
+    }
+
+  if (ioparm.delim != NULL)
+    cf_strcpy (ioparm.delim, ioparm.delim_len, undefined);
+
+  if (ioparm.pad != NULL)
+    cf_strcpy (ioparm.pad, ioparm.pad_len, undefined);
+
+}
+
+
+
+void
+st_inquire (void)
+{
+  unit_t *u;
+
+  library_start ();
+
+  if (ioparm.file == NULL)
+    inquire_via_unit (find_unit (ioparm.unit));
+  else
+    {
+      u = find_file ();
+      if (u == NULL)
+	inquire_via_filename ();
+      else
+	inquire_via_unit (u);
+    }
+
+  library_end ();
+}
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
new file mode 100644
index 0000000..3b01912
--- /dev/null
+++ b/libgfortran/io/io.h
@@ -0,0 +1,653 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#ifndef GFOR_IO_H
+#define GFOR_IO_H
+
+/* IO library include.  */
+
+#include <setjmp.h>
+#include "libgfortran.h"
+#define DEFAULT_TEMPDIR "/var/tmp"
+
+/* Basic types used in data transfers.  */
+
+typedef enum
+{ BT_NULL, BT_INTEGER, BT_LOGICAL, BT_CHARACTER, BT_REAL,
+  BT_COMPLEX
+}
+bt;
+
+
+typedef enum
+{ SUCCESS = 1, FAILURE }
+try;
+
+typedef struct stream
+{
+  char *(*alloc_w_at) (struct stream *, int *, offset_t);
+  char *(*alloc_r_at) (struct stream *, int *, offset_t);
+    try (*sfree) (struct stream *);
+    try (*close) (struct stream *);
+    try (*seek) (struct stream *, offset_t);
+    try (*truncate) (struct stream *);
+}
+stream;
+
+
+/* Macros for doing file I/O given a stream.  */
+
+#define sfree(s) ((s)->sfree)(s)
+#define sclose(s) ((s)->close)(s)
+
+#define salloc_r(s, len) ((s)->alloc_r_at)(s, len, -1)
+#define salloc_w(s, len) ((s)->alloc_w_at)(s, len, -1)
+
+#define salloc_r_at(s, len, where) ((s)->alloc_r_at)(s, len, where)
+#define salloc_w_at(s, len, where) ((s)->alloc_w_at)(s, len, where)
+
+#define sseek(s, pos) ((s)->seek)(s, pos)
+#define struncate(s) ((s)->truncate)(s)
+
+/* Namelist represent object */
+/*
+   Namelist Records
+       &groupname  object=value [,object=value].../
+     or
+       &groupname  object=value [,object=value]...&groupname
+
+  Even more complex, during the execution of a program containing a
+  namelist READ statement, you can specify a question mark character(?)
+  or a question mark character preceded by an equal sign(=?) to get
+  the information of the namelist group. By '?', the name of variables
+  in the namelist will be displayed, by '=?', the name and value of
+  variables will be displayed.
+
+  All these requirements need a new data structure to record all info
+  about the namelist.
+*/
+
+typedef struct namelist_type
+{
+  char * var_name;
+  void * mem_pos;
+  int  value_acquired;
+  int len;
+  bt type;
+  struct namelist_type * next;
+}
+namelist_info;
+
+/* Options for the OPEN statement.  */
+
+typedef enum
+{ ACCESS_SEQUENTIAL, ACCESS_DIRECT,
+  ACCESS_UNSPECIFIED
+}
+unit_access;
+
+typedef enum
+{ ACTION_READ, ACTION_WRITE, ACTION_READWRITE,
+  ACTION_UNSPECIFIED
+}
+unit_action;
+
+typedef enum
+{ BLANK_NULL, BLANK_ZERO, BLANK_UNSPECIFIED }
+unit_blank;
+
+typedef enum
+{ DELIM_NONE, DELIM_APOSTROPHE, DELIM_QUOTE,
+  DELIM_UNSPECIFIED
+}
+unit_delim;
+
+typedef enum
+{ FORM_FORMATTED, FORM_UNFORMATTED, FORM_UNSPECIFIED }
+unit_form;
+
+typedef enum
+{ POSITION_ASIS, POSITION_REWIND, POSITION_APPEND,
+  POSITION_UNSPECIFIED
+}
+unit_position;
+
+typedef enum
+{ STATUS_UNKNOWN, STATUS_OLD, STATUS_NEW, STATUS_SCRATCH,
+  STATUS_REPLACE, STATUS_UNSPECIFIED
+}
+unit_status;
+
+typedef enum
+{ PAD_YES, PAD_NO, PAD_UNSPECIFIED }
+unit_pad;
+
+typedef enum
+{ ADVANCE_YES, ADVANCE_NO, ADVANCE_UNSPECIFIED }
+unit_advance;
+
+
+
+/* Statement parameters.  These are all the things that can appear in
+   an I/O statement.  Some are inputs and some are outputs, but none
+   are both.  All of these values are initially zeroed and are zeroed
+   at the end of a library statement.  The relevant values need to be
+   set before entry to an I/O statement.  This structure needs to be
+   duplicated by the back end.  */
+
+typedef struct
+{
+  int unit;
+  int err, end, eor, list_format;	/* These are flags, not values.  */
+
+/* Return values from library statements.  These are returned only if
+   the labels are specified in the statement itself and the condition
+   occurs.  In most cases, none of the labels are specified and the
+   return value does not have to be checked.  Must be consistent with
+   the front end.  */
+
+  enum
+  {
+    LIBRARY_OK = 0,
+    LIBRARY_ERROR,
+    LIBRARY_END,
+    LIBRARY_EOR
+  }
+  library_return;
+
+  int *iostat, *exist, *opened, *number, *named, rec, *nextrec, *size;
+
+  int recl_in; 
+  int *recl_out;
+
+  char *file;
+  int file_len;
+  char *status;
+  int status_len;
+  char *access;
+  int access_len;
+  char *form;
+  int form_len;
+  char *blank;
+  int blank_len;
+  char *position;
+  int position_len;
+  char *action;
+  int action_len;
+  char *delim;
+  int delim_len;
+  char *pad;
+  int pad_len;
+  char *format;
+  int format_len;
+  char *advance;
+  int advance_len;
+  char *name;
+  int name_len;
+  char *internal_unit;
+  int internal_unit_len;
+  char *sequential;
+  int sequential_len;
+  char *direct;
+  int direct_len;
+  char *formatted;
+  int formatted_len;
+  char *unformatted;
+  int unformatted_len;
+  char *read;
+  int read_len;
+  char *write;
+  int write_len;
+  char *readwrite;
+  int readwrite_len;
+
+/* namelist related data */
+  char * namelist_name;
+  int namelist_name_len;
+  int namelist_read_mode;
+}
+st_parameter;
+
+
+
+#define ioparm prefix(ioparm)
+extern st_parameter ioparm;
+
+#define ionml prefix(ionml)
+extern namelist_info * ionml;
+
+typedef struct
+{
+  unit_access access;
+  unit_action action;
+  unit_blank blank;
+  unit_delim delim;
+  unit_form form;
+  int is_notpadded;
+  unit_position position;
+  unit_status status;
+  unit_pad pad;
+}
+unit_flags;
+
+
+/* The default value of record length is defined here.  This value can
+   be overriden by the OPEN statement or by an environment variable.  */
+
+#define DEFAULT_RECL 10000
+
+
+typedef struct unit_t
+{
+  int unit_number;
+
+  stream *s;
+
+  struct unit_t *left, *right;	/* Treap links.  */
+  int priority;
+
+  int read_bad, current_record;
+  enum
+  { NO_ENDFILE, AT_ENDFILE, AFTER_ENDFILE }
+  endfile;
+
+  unit_flags flags;
+  offset_t recl, last_record, maxrec, bytes_left;
+
+  /* recl           -- Record length of the file.
+     last_record    -- Last record number read or written
+     maxrec         -- Maximum record number in a direct access file
+     bytes_left     -- Bytes left in current record.  */
+
+  int file_len;
+  char file[1];	      /* Filename is allocated at the end of the structure.  */
+}
+unit_t;
+
+/* Global variables.  Putting these in a structure makes it easier to
+   maintain, particularly with the constraint of a prefix.  */
+
+typedef struct
+{
+  int in_library;       /* Nonzero if a library call is being processed.  */
+  int size;	/* Bytes processed by the current data-transfer statement.  */
+  offset_t max_offset;	/* Maximum file offset.  */
+  int item_count;	/* Item number in a formatted data transfer.  */
+  int reversion_flag;	/* Format reversion has occurred.  */
+  int first_item;
+
+  unit_t *unit_root;
+  int seen_dollar;
+
+  enum {READING, WRITING} mode;
+
+  unit_blank blank_status;
+  enum {SIGN_S, SIGN_SS, SIGN_SP} sign_status;
+  int scale_factor;
+  jmp_buf eof_jump;  
+}
+global_t;
+
+
+#define g prefix(g)
+extern global_t g;
+
+
+#define current_unit prefix(current_unit)
+extern unit_t *current_unit;
+
+/* Format tokens.  Only about half of these can be stored in the
+   format nodes.  */
+
+typedef enum
+{
+  FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
+  FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
+  FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
+  FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
+  FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END
+}
+format_token;
+
+
+/* Format nodes.  A format string is converted into a tree of these
+   structures, which is traversed as part of a data transfer statement.  */
+
+typedef struct fnode
+{
+  format_token format;
+  int repeat;
+  struct fnode *next;
+  char *source;
+
+  union
+  {
+    struct
+    {
+      int w, d, e;
+    }
+    real;
+
+    struct
+    {
+      int length;
+      char *p;
+    }
+    string;
+
+    struct
+    {
+      int w, m;
+    }
+    integer;
+
+    int w;
+    int k;
+    int r;
+    int n;
+
+    struct fnode *child;
+  }
+  u;
+
+  /* Members for traversing the tree during data transfer.  */
+
+  int count;
+  struct fnode *current;
+
+}
+fnode;
+
+
+/* unix.c */
+
+#define sys_exit prefix(sys_exit)
+void sys_exit (int) __attribute__ ((noreturn));
+
+#define move_pos_offset prefix(move_pos_offset)
+int move_pos_offset (stream *, int);
+
+#define get_oserror prefix(get_oserror)
+const char *get_oserror (void);
+
+#define compare_files prefix(compare_files)
+int compare_files (stream *, stream *);
+
+#define init_error_stream prefix(init_error_stream)
+stream *init_error_stream (void);
+
+#define open_external prefix(open_external)
+stream *open_external (unit_action, unit_status);
+
+#define open_internal prefix(open_internal)
+stream *open_internal (char *, int);
+
+#define input_stream prefix(input_stream)
+stream *input_stream (void);
+
+#define output_stream prefix(output_stream)
+stream *output_stream (void);
+
+#define compare_file_filename prefix(compare_file_filename)
+int compare_file_filename (stream *, const char *, int);
+
+#define find_file prefix(find_file)
+unit_t *find_file (void);
+
+#define stream_at_bof prefix(stream_at_bof)
+int stream_at_bof (stream *);
+
+#define stream_at_eof prefix(stream_at_eof)
+int stream_at_eof (stream *);
+
+#define delete_file prefix(delete_file)
+int delete_file (unit_t *);
+
+#define file_exists prefix(file_exists)
+int file_exists (void);
+
+#define inquire_sequential prefix(inquire_sequential)
+const char *inquire_sequential (const char *, int);
+
+#define inquire_direct prefix(inquire_direct)
+const char *inquire_direct (const char *, int);
+
+#define inquire_formatted prefix(inquire_formatted)
+const char *inquire_formatted (const char *, int);
+
+#define inquire_unformatted prefix(inquire_unformatted)
+const char *inquire_unformatted (const char *, int);
+
+#define inquire_read prefix(inquire_read)
+const char *inquire_read (const char *, int);
+
+#define inquire_write prefix(inquire_write)
+const char *inquire_write (const char *, int);
+
+#define inquire_readwrite prefix(inquire_readwrite)
+const char *inquire_readwrite (const char *, int);
+
+#define file_length prefix(file_length)
+offset_t file_length (stream *);
+
+#define file_position prefix(file_position)
+offset_t file_position (stream *);
+
+#define is_seekable prefix(is_seekable)
+int is_seekable (stream *);
+
+#define empty_internal_buffer prefix(empty_internal_buffer)
+void empty_internal_buffer(stream *);
+
+
+/* unit.c */
+
+#define insert_unit prefix(insert_unix)
+void insert_unit (unit_t *);
+
+#define close_unit prefix(close_unit)
+int close_unit (unit_t *);
+
+#define is_internal_unit prefix(is_internal_unit)
+int is_internal_unit (void);
+
+#define find_unit prefix(find_unit)
+unit_t *find_unit (int);
+
+#define get_unit prefix(get_unit)
+unit_t *get_unit (int);
+
+/* open.c */
+
+#define test_endfile prefix(test_endfile)
+void test_endfile (unit_t *);
+
+#define new_unit prefix(new_unit)
+void new_unit (unit_flags *);
+
+/* format.c */
+
+#define parse_format prefix(parse_format)
+void parse_format (void);
+
+#define next_format prefix(next_format)
+fnode *next_format (void);
+
+#define unget_format prefix(unget_format)
+void unget_format (fnode *);
+
+#define format_error prefix(format_error)
+void format_error (fnode *, const char *);
+
+#define free_fnodes prefix(free_fnodes)
+void free_fnodes (void);
+
+/* transfer.c */
+
+#define SCRATCH_SIZE 300
+
+#define scratch prefix(scratch)
+extern char scratch[];
+
+#define type_name prefix(type_name)
+const char *type_name (bt);
+
+#define read_block prefix(read_block)
+void *read_block (int *);
+
+#define write_block prefix(write_block)
+void *write_block (int);
+
+#define transfer_integer prefix(transfer_integer)
+void transfer_integer (void *, int);
+
+#define transfer_real prefix(transfer_real)
+void transfer_real (void *, int);
+
+#define transfer_logical prefix(transfer_logical)
+void transfer_logical (void *, int);
+
+#define transfer_character prefix(transfer_character)
+void transfer_character (void *, int);
+
+#define transfer_complex prefix(transfer_complex)
+void transfer_complex (void *, int);
+
+#define next_record prefix(next_record)
+void next_record (int);
+
+#define st_set_nml_var_int prefix(st_set_nml_var_int)
+void st_set_nml_var_int (void * , char * , int , int );
+
+#define st_set_nml_var_float prefix(st_set_nml_var_float)
+void st_set_nml_var_float (void * , char * , int , int );
+
+#define st_set_nml_var_char prefix(st_set_nml_var_char)
+void st_set_nml_var_char (void * , char * , int , int );
+
+#define st_set_nml_var_complex prefix(st_set_nml_var_complex)
+void st_set_nml_var_complex (void * , char * , int , int );
+
+#define st_set_nml_var_log prefix(st_set_nml_var_log)
+void st_set_nml_var_log (void * , char * , int , int );
+
+/* read.c */
+
+#define set_integer prefix(set_integer)
+void set_integer (void *, int64_t, int);
+
+#define max_value prefix(max_value)
+uint64_t max_value (int, int);
+
+#define convert_real prefix(convert_real)
+int convert_real (void *, const char *, int);
+
+#define read_a prefix(read_a)
+void read_a (fnode *, char *, int);
+
+#define read_f prefix(read_f)
+void read_f (fnode *, char *, int);
+
+#define read_l prefix(read_l)
+void read_l (fnode *, char *, int);
+
+#define read_x prefix(read_x)
+void read_x (fnode *);
+
+#define read_radix prefix(read_radix)
+void read_radix (fnode *, char *, int, int);
+
+#define read_decimal prefix(read_decimal)
+void read_decimal (fnode *, char *, int);
+
+/* list_read.c */
+
+#define list_formatted_read prefix(list_formatted_read)
+void list_formatted_read (bt, void *, int);
+
+#define finish_list_read prefix(finish_list_read)
+void finish_list_read (void);
+
+#define init_at_eol prefix(init_at_eol)
+void init_at_eol();
+
+#define namelist_read prefix(namelist_read)
+void namelist_read();
+
+#define namelist_write prefix(namelist_write)
+void namelist_write();
+
+/* write.c */
+
+#define write_a prefix(write_a)
+void write_a (fnode *, const char *, int);
+
+#define write_b prefix(write_b)
+void write_b (fnode *, const char *, int);
+
+#define write_d prefix(write_d)
+void write_d (fnode *, const char *, int);
+
+#define write_e prefix(write_e)
+void write_e (fnode *, const char *, int);
+
+#define write_en prefix(write_en)
+void write_en (fnode *, const char *, int);
+
+#define write_es prefix(write_es)
+void write_es (fnode *, const char *, int);
+
+#define write_f prefix(write_f)
+void write_f (fnode *, const char *, int);
+
+#define write_i prefix(write_i)
+void write_i (fnode *, const char *, int);
+
+#define write_l prefix(write_l)
+void write_l (fnode *, char *, int);
+
+#define write_o prefix(write_o)
+void write_o (fnode *, const char *, int);
+
+#define write_x prefix(write_x)
+void write_x (fnode *);
+
+#define write_z prefix(write_z)
+void write_z (fnode *, const char *, int);
+
+#define list_formatted_write prefix(list_formatted_write)
+void list_formatted_write (bt, void *, int);
+
+
+#define st_open prefix(st_open)
+#define st_close prefix(st_close)
+#define st_inquire prefix(st_inquire)
+#define st_rewind prefix(st_rewind)
+#define st_read prefix(st_read)
+#define st_read_done prefix(st_read_done)
+#define st_write prefix(st_write)
+#define st_write_done prefix(st_write_done)
+#define st_backspace prefix(st_backspace)
+#define st_endfile prefix(st_endfile)
+
+
+void __MAIN (void);
+
+#endif
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
new file mode 100644
index 0000000..2b62d31
--- /dev/null
+++ b/libgfortran/io/list_read.c
@@ -0,0 +1,1531 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+#include "config.h"
+#include <string.h>
+#include <ctype.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* List directed input.  Several parsing subroutines are practically
+ * reimplemented from formatted input, the reason being that there are
+ * all kinds of small differences between formatted and list directed
+ * parsing. */
+
+
+/* Subroutines for reading characters from the input.  Because a
+ * repeat count is ambiguous with an integer, we have to read the
+ * whole digit string before seeing if there is a '*' which signals
+ * the repeat count.  Since we can have a lot of potential leading
+ * zeros, we have to be able to back up by arbitrary amount.  Because
+ * the input might not be seekable, we have to buffer the data
+ * ourselves.  Data is buffered in scratch[] until it becomes too
+ * large, after which we start allocating memory on the heap.  */
+
+static int repeat_count, saved_length, saved_used, input_complete, at_eol;
+static int comma_flag, namelist_mode;
+
+static char last_char, *saved_string;
+static bt saved_type;
+
+
+
+/* Storage area for values except for strings.  Must be large enough
+ * to hold a complex value (two reals) of the largest kind */
+
+static char value[20];
+
+#define CASE_DIGITS   case '0': case '1': case '2': case '3': case '4': \
+                      case '5': case '6': case '7': case '8': case '9'
+
+#define CASE_SEPARATORS  case ' ': case ',': case '/': case '\n': case '\t'
+
+/* This macro assumes that we're operating on a variable */
+
+#define is_separator(c) (c == '/' ||  c == ',' || c == '\n' || c == ' ' \
+                         || c == '\t')
+
+/* Maximum repeat count.  Less than ten times the maximum signed int32. */
+
+#define MAX_REPEAT 200000000
+
+
+/* push_char()-- Save a character to a string buffer, enlarging it as
+ * necessary. */
+
+static void
+push_char (char c)
+{
+  char *new;
+
+  if (saved_string == NULL)
+    {
+      saved_string = scratch;
+      memset (saved_string,0,SCRATCH_SIZE);
+      saved_length = SCRATCH_SIZE;
+      saved_used = 0;
+    }
+
+  if (saved_used >= saved_length)
+    {
+      saved_length = 2 * saved_length;
+      new = get_mem (2 * saved_length);
+
+      memset (new,0,2 * saved_length);
+
+      memcpy (new, saved_string, saved_used);
+      if (saved_string != scratch)
+	free_mem (saved_string);
+
+      saved_string = new;
+    }
+
+  saved_string[saved_used++] = c;
+}
+
+
+/* free_saved()-- Free the input buffer if necessary. */
+
+static void
+free_saved (void)
+{
+
+  if (saved_string == NULL)
+    return;
+
+  if (saved_string != scratch)
+    free_mem (saved_string);
+
+  saved_string = NULL;
+}
+
+
+static char
+next_char (void)
+{
+  int length;
+  char c, *p;
+
+  if (last_char != '\0')
+    {
+      at_eol = 0;
+      c = last_char;
+      last_char = '\0';
+      goto done;
+    }
+
+  length = 1;
+
+  p = salloc_r (current_unit->s, &length);
+  if (p == NULL)
+    {
+      generate_error (ERROR_OS, NULL);
+      return '\0';
+    }
+
+  if (length == 0)
+    longjmp (g.eof_jump, 1);
+  c = *p;
+
+done:
+  at_eol = (c == '\n');
+  return c;
+}
+
+
+/* unget_char()-- Push a character back onto the input */
+
+static void
+unget_char (char c)
+{
+
+  last_char = c;
+}
+
+
+/* eat_spaces()-- Skip over spaces in the input.  Returns the nonspace
+ * character that terminated the eating and also places it back on the
+ * input. */
+
+static char
+eat_spaces (void)
+{
+  char c;
+
+  do
+    {
+      c = next_char ();
+    }
+  while (c == ' ' || c == '\t');
+
+  unget_char (c);
+  return c;
+}
+
+
+/* eat_separator()-- Skip over a separator.  Technically, we don't
+ * always eat the whole separator.  This is because if we've processed
+ * the last input item, then a separator is unnecessary.  Plus the
+ * fact that operating systems usually deliver console input on a line
+ * basis.
+ *
+ * The upshot is that if we see a newline as part of reading a
+ * separator, we stop reading.  If there are more input items, we
+ * continue reading the separator with finish_separator() which takes
+ * care of the fact that we may or may not have seen a comma as part
+ * of the separator. */
+
+static void
+eat_separator (void)
+{
+  char c;
+
+  eat_spaces ();
+  comma_flag = 0;
+
+  c = next_char ();
+  switch (c)
+    {
+    case ',':
+      comma_flag = 1;
+      eat_spaces ();
+      break;
+
+    case '/':
+      input_complete = 1;
+      next_record (0);
+      break;
+
+    case '\n':
+      break;
+
+    case '!':
+      if (namelist_mode)
+	{			/* Eat a namelist comment */
+	  do
+	    c = next_char ();
+	  while (c != '\n');
+
+	  break;
+	}
+
+      /* Fall Through */
+
+    default:
+      unget_char (c);
+      break;
+    }
+}
+
+
+/* finish_separator()-- Finish processing a separator that was
+ * interrupted by a newline.  If we're here, then another data item is
+ * present, so we finish what we started on the previous line. */
+
+static void
+finish_separator (void)
+{
+  char c;
+
+restart:
+  eat_spaces ();
+
+  c = next_char ();
+  switch (c)
+    {
+    case ',':
+      if (comma_flag)
+	unget_char (c);
+      else
+	{
+	  c = eat_spaces ();
+	  if (c == '\n')
+	    goto restart;
+	}
+
+      break;
+
+    case '/':
+      input_complete = 1;
+      next_record (0);
+      break;
+
+    case '\n':
+      goto restart;
+
+    case '!':
+      if (namelist_mode)
+	{
+	  do
+	    c = next_char ();
+	  while (c != '\n');
+
+	  goto restart;
+	}
+
+    default:
+      unget_char (c);
+      break;
+    }
+}
+
+
+/* convert_integer()-- Convert an unsigned string to an integer.  The
+ * length value is -1 if we are working on a repeat count.  Returns
+ * nonzero if we have a range problem.  As a side effect, frees the
+ * saved_string. */
+
+static int
+convert_integer (int length, int negative)
+{
+  char c, *buffer, message[100];
+  int m;
+  int64_t v, max, max10;
+
+  buffer = saved_string;
+  v = 0;
+
+  max = (length == -1) ? MAX_REPEAT : max_value (length, 1);
+  max10 = max / 10;
+
+  for (;;)
+    {
+      c = *buffer++;
+      if (c == '\0')
+	break;
+      c -= '0';
+
+      if (v > max10)
+	goto overflow;
+      v = 10 * v;
+
+      if (v > max - c)
+	goto overflow;
+      v += c;
+    }
+
+  m = 0;
+
+  if (length != -1)
+    {
+      if (negative)
+	v = -v;
+      set_integer (value, v, length);
+    }
+  else
+    {
+      repeat_count = v;
+
+      if (repeat_count == 0)
+	{
+	  st_sprintf (message, "Zero repeat count in item %d of list input",
+		      g.item_count);
+
+	  generate_error (ERROR_READ_VALUE, message);
+	  m = 1;
+	}
+    }
+
+  free_saved ();
+  return m;
+
+overflow:
+  if (length == -1)
+    st_sprintf (message, "Repeat count overflow in item %d of list input",
+		g.item_count);
+  else
+    st_sprintf (message, "Integer overflow while reading item %d",
+		g.item_count);
+
+  free_saved ();
+  generate_error (ERROR_READ_VALUE, message);
+
+  return 1;
+}
+
+
+/* parse_repeat()-- Parse a repeat count for logical and complex
+ * values which cannot begin with a digit.  Returns nonzero if we are
+ * done, zero if we should continue on. */
+
+static int
+parse_repeat (void)
+{
+  char c, message[100];
+  int repeat;
+
+  c = next_char ();
+  switch (c)
+    {
+    CASE_DIGITS:
+      repeat = c - '0';
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (c);
+      eat_separator ();
+      return 1;
+
+    default:
+      unget_char (c);
+      return 0;
+    }
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  repeat = 10 * repeat + c - '0';
+
+	  if (repeat > MAX_REPEAT)
+	    {
+	      st_sprintf (message,
+			  "Repeat count overflow in item %d of list input",
+			  g.item_count);
+
+	      generate_error (ERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  break;
+
+	case '*':
+	  if (repeat == 0)
+	    {
+	      st_sprintf (message,
+			  "Zero repeat count in item %d of list input",
+			  g.item_count);
+
+	      generate_error (ERROR_READ_VALUE, message);
+	      return 1;
+	    }
+
+	  goto done;
+
+	default:
+	  goto bad_repeat;
+	}
+    }
+
+done:
+  repeat_count = repeat;
+  return 0;
+
+bad_repeat:
+  st_sprintf (message, "Bad repeat count in item %d of list input",
+	      g.item_count);
+
+  generate_error (ERROR_READ_VALUE, message);
+  return 1;
+}
+
+
+/* read_logical()-- Read a logical character on the input */
+
+static void
+read_logical (int length)
+{
+  char c, message[100];
+  int v;
+
+  if (parse_repeat ())
+    return;
+
+  c = next_char ();
+  switch (c)
+    {
+    case 't':
+    case 'T':
+      v = 1;
+      break;
+    case 'f':
+    case 'F':
+      v = 0;
+      break;
+
+    case '.':
+      c = next_char ();
+      switch (c)
+	{
+	case 't':
+	case 'T':
+	  v = 1;
+	  break;
+	case 'f':
+	case 'F':
+	  v = 0;
+	  break;
+	default:
+	  goto bad_logical;
+	}
+
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (c);
+      eat_separator ();
+      return;			/* Null value */
+
+    default:
+      goto bad_logical;
+    }
+
+  saved_type = BT_LOGICAL;
+  saved_length = length;
+
+  /* Eat trailing garbage */
+
+  do
+    {
+      c = next_char ();
+    }
+  while (!is_separator (c));
+
+  unget_char (c);
+  eat_separator ();
+  free_saved ();
+  set_integer ((int *) value, v, length);
+
+  return;
+
+bad_logical:
+  st_sprintf (message, "Bad logical value while reading item %d",
+	      g.item_count);
+
+  generate_error (ERROR_READ_VALUE, message);
+}
+
+
+/* read_integer()-- Reading integers is tricky because we can actually
+ * be reading a repeat count.  We have to store the characters in a
+ * buffer because we could be reading an integer that is larger than the
+ * default int used for repeat counts.  */
+
+static void
+read_integer (int length)
+{
+  char c, message[100];
+  int negative;
+
+  negative = 0;
+
+  c = next_char ();
+  switch (c)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      c = next_char ();
+      goto get_integer;
+
+    CASE_SEPARATORS:		/* Single null */
+      unget_char (c);
+      eat_separator ();
+      return;
+
+    CASE_DIGITS:
+      push_char (c);
+      break;
+
+    default:
+      goto bad_integer;
+    }
+
+  /* Take care of what may be a repeat count */
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	case '*':
+	  push_char ('\0');
+	  goto repeat;
+
+	CASE_SEPARATORS:	/* Not a repeat count */
+	  goto done;
+
+	default:
+	  goto bad_integer;
+	}
+    }
+
+repeat:
+  if (convert_integer (-1, 0))
+    return;
+
+/* Get the real integer */
+
+  c = next_char ();
+  switch (c)
+    {
+    CASE_DIGITS:
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (c);
+      eat_separator ();
+      return;
+
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      c = next_char ();
+      break;
+    }
+
+get_integer:
+  if (!isdigit (c))
+    goto bad_integer;
+  push_char (c);
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	default:
+	  goto bad_integer;
+	}
+    }
+
+bad_integer:
+  free_saved ();
+
+  st_sprintf (message, "Bad integer for item %d in list input", g.item_count);
+  generate_error (ERROR_READ_VALUE, message);
+
+  return;
+
+done:
+  unget_char (c);
+  eat_separator ();
+
+  push_char ('\0');
+  if (convert_integer (length, negative))
+    {
+       free_saved ();
+       return;
+    }
+
+  free_saved ();
+  saved_type = BT_INTEGER;
+}
+
+
+/* read_character()-- Read a character variable */
+
+static void
+read_character (int length)
+{
+  char c, quote, message[100];
+
+  quote = ' ';			/* Space means no quote character */
+
+  c = next_char ();
+  switch (c)
+    {
+    CASE_DIGITS:
+      push_char (c);
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (c);		/* NULL value */
+      eat_separator ();
+      return;
+
+    case '"':
+    case '\'':
+      quote = c;
+      goto get_string;
+
+    default:
+      push_char (c);
+      goto get_string;
+    }
+
+/* Deal with a possible repeat count */
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	CASE_SEPARATORS:
+	  unget_char (c);
+	  goto done;		/* String was only digits! */
+
+	case '*':
+	  push_char ('\0');
+	  goto got_repeat;
+
+	default:
+	  push_char (c);
+	  goto get_string;	/* Not a repeat count after all */
+	}
+    }
+
+got_repeat:
+  if (convert_integer (-1, 0))
+    return;
+
+  /* Now get the real string */
+
+  c = next_char ();
+  switch (c)
+    {
+    CASE_SEPARATORS:
+      unget_char (c);		/* repeated NULL values */
+      eat_separator ();
+      return;
+
+    case '"':
+    case '\'':
+      quote = c;
+      break;
+
+    default:
+      push_char (c);
+      break;
+    }
+
+get_string:
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	case '"':
+	case '\'':
+	  if (c != quote)
+	    {
+	      push_char (c);
+	      break;
+	    }
+
+	  /* See if we have a doubled quote character or the end of the string */
+
+	  c = next_char ();
+	  if (c == quote)
+	    {
+	      push_char (quote);
+	      break;
+	    }
+
+	  unget_char (c);
+	  goto done;
+
+	CASE_SEPARATORS:
+	  if (quote == ' ')
+	    {
+	      unget_char (c);
+	      goto done;
+	    }
+
+	  if (c != '\n')
+	    push_char (c);
+	  break;
+
+	default:
+	  push_char (c);
+	  break;
+	}
+    }
+
+/* At this point, we have to have a separator, or else the string is invalid */
+
+done:
+  c = next_char ();
+  if (is_separator (c))
+    {
+      unget_char (c);
+      eat_separator ();
+      saved_type = BT_CHARACTER;
+    }
+  else
+    {
+      free_saved ();
+      st_sprintf (message, "Invalid string input in item %d", g.item_count);
+      generate_error (ERROR_READ_VALUE, message);
+    }
+}
+
+
+/* parse_real()-- Parse a component of a complex constant or a real
+ * number that we are sure is already there.  This is a straight real
+ * number parser. */
+
+static int
+parse_real (void *buffer, int length)
+{
+  char c, message[100];
+  int m, seen_dp;
+
+  c = next_char ();
+  if (c == '-' || c == '+')
+    {
+      push_char (c);
+      c = next_char ();
+    }
+
+  if (!isdigit (c) && c != '.')
+    goto bad;
+
+  push_char (c);
+
+  seen_dp = (c == '.') ? 1 : 0;
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	case '.':
+	  if (seen_dp)
+	    goto bad;
+
+	  seen_dp = 1;
+	  push_char (c);
+	  break;
+
+	case 'e':
+	case 'E':
+	case 'd':
+	case 'D':
+	  push_char ('e');
+	  goto exp1;
+
+	case '-':
+	case '+':
+	  push_char ('e');
+	  push_char (c);
+	  c = next_char ();
+	  goto exp2;
+
+	CASE_SEPARATORS:
+	  unget_char (c);
+	  goto done;
+
+	default:
+	  goto done;
+	}
+    }
+
+exp1:
+  c = next_char ();
+  if (c != '-' && c != '+')
+    push_char ('+');
+  else
+    {
+      push_char (c);
+      c = next_char ();
+    }
+
+exp2:
+  if (!isdigit (c))
+    goto bad;
+  push_char (c);
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	CASE_SEPARATORS:
+	  unget_char (c);
+	  goto done;
+
+	default:
+	  goto done;
+	}
+    }
+
+done:
+  unget_char (c);
+  push_char ('\0');
+
+  m = convert_real (buffer, saved_string, length);
+  free_saved ();
+
+  return m;
+
+bad:
+  free_saved ();
+  st_sprintf (message, "Bad floating point number for item %d", g.item_count);
+  generate_error (ERROR_READ_VALUE, message);
+
+  return 1;
+}
+
+
+/* read_complex()-- Reading a complex number is straightforward
+ * because we can tell what it is right away. */
+
+static void
+read_complex (int length)
+{
+  char message[100];
+  char c;
+
+  if (parse_repeat ())
+    return;
+
+  c = next_char ();
+  switch (c)
+    {
+    case '(':
+      break;
+
+    CASE_SEPARATORS:
+      unget_char (c);
+      eat_separator ();
+      return;
+
+    default:
+      goto bad_complex;
+    }
+
+  eat_spaces ();
+  if (parse_real (value, length))
+    return;
+
+  eat_spaces ();
+  if (next_char () != ',')
+    goto bad_complex;
+
+  eat_spaces ();
+  if (parse_real (value + length, length))
+    return;
+
+  eat_spaces ();
+  if (next_char () != ')')
+    goto bad_complex;
+
+  c = next_char ();
+  if (!is_separator (c))
+    goto bad_complex;
+
+  unget_char (c);
+  eat_separator ();
+
+  free_saved ();
+  saved_type = BT_COMPLEX;
+  return;
+
+bad_complex:
+  st_sprintf (message, "Bad complex value in item %d of list input",
+	      g.item_count);
+
+  generate_error (ERROR_READ_VALUE, message);
+}
+
+
+/* read_real()-- Parse a real number with a possible repeat count. */
+
+static void
+read_real (int length)
+{
+  char c, message[100];
+  int seen_dp;
+
+  seen_dp = 0;
+
+  c = next_char ();
+  switch (c)
+    {
+    CASE_DIGITS:
+      push_char (c);
+      break;
+
+    case '.':
+      push_char (c);
+      seen_dp = 1;
+      break;
+
+    case '+':
+    case '-':
+      goto got_sign;
+
+    CASE_SEPARATORS:
+      unget_char (c);		/* Single null */
+      eat_separator ();
+      return;
+
+    default:
+      goto bad_real;
+    }
+
+  /* Get the digit string that might be a repeat count */
+
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	case '.':
+          if (seen_dp)
+            goto bad_real;
+
+	  seen_dp = 1;
+	  push_char (c);
+	  goto real_loop;
+
+	case 'E':
+	case 'e':
+	case 'D':
+	case 'd':
+	  goto exp1;
+
+	case '+':
+	case '-':
+	  push_char ('e');
+	  push_char (c);
+	  c = next_char ();
+	  goto exp2;
+
+	case '*':
+	  push_char ('\0');
+	  goto got_repeat;
+
+	CASE_SEPARATORS:
+          if (c != '\n')
+            unget_char (c);        /* Real number that is just a digit-string */
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+got_repeat:
+  if (convert_integer (-1, 0))
+    return;
+
+/* Now get the number itself */
+
+  c = next_char ();
+  if (is_separator (c))
+    {				/* Repeated null value */
+      unget_char (c);
+      eat_separator ();
+      return;
+    }
+
+  if (c != '-' && c != '+')
+    push_char ('+');
+  else
+    {
+    got_sign:
+      push_char (c);
+      c = next_char ();
+    }
+
+  if (!isdigit (c) && c != '.')
+    goto bad_real;
+
+  if (c == '.')
+    {
+      if (seen_dp)
+        goto bad_real;
+      else
+        seen_dp = 1;
+    }
+
+  push_char (c);
+
+real_loop:
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	CASE_SEPARATORS:
+	  goto done;
+
+	case '.':
+	  if (seen_dp)
+	    goto bad_real;
+
+	  seen_dp = 1;
+	  push_char (c);
+	  break;
+
+	case 'E':
+	case 'e':
+	case 'D':
+	case 'd':
+	  goto exp1;
+
+	case '+':
+	case '-':
+	  push_char ('e');
+	  push_char (c);
+	  c = next_char ();
+	  goto exp2;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+exp1:
+  push_char ('e');
+
+  c = next_char ();
+  if (c != '+' && c != '-')
+    push_char ('+');
+  else
+    {
+      push_char (c);
+      c = next_char ();
+    }
+
+exp2:
+  if (!isdigit (c))
+    goto bad_real;
+  push_char (c);
+
+  for (;;)
+    {
+      c = next_char ();
+
+      switch (c)
+	{
+	CASE_DIGITS:
+	  push_char (c);
+	  break;
+
+	CASE_SEPARATORS:
+	  unget_char (c);
+	  eat_separator ();
+	  goto done;
+
+	default:
+	  goto bad_real;
+	}
+    }
+
+done:
+  push_char ('\0');
+  if (convert_real (value, saved_string, length))
+    return;
+
+  free_saved ();
+  saved_type = BT_REAL;
+  return;
+
+bad_real:
+  st_sprintf (message, "Bad real number in item %d of list input",
+	      g.item_count);
+
+  generate_error (ERROR_READ_VALUE, message);
+}
+
+
+/* check_type()-- Check the current type against the saved type to
+ * make sure they are compatible.  Returns nonzero if incompatible.  */
+
+static int
+check_type (bt type, int len)
+{
+  char message[100];
+
+  if (saved_type != BT_NULL && saved_type != type)
+    {
+      st_sprintf (message, "Read type %s where %s was expected for item %d",
+		  type_name (saved_type), type_name (type), g.item_count);
+
+      generate_error (ERROR_READ_VALUE, message);
+      return 1;
+    }
+
+  if (saved_type == BT_NULL || saved_type == BT_CHARACTER)
+    return 0;
+
+  if (saved_length != len)
+    {
+      st_sprintf (message,
+		  "Read kind %d %s where kind %d is required for item %d",
+		  saved_length, type_name (saved_type), len, g.item_count);
+      generate_error (ERROR_READ_VALUE, message);
+      return 1;
+    }
+
+  return 0;
+}
+
+
+/* list_formatted_read()-- Top level data transfer subroutine for list
+ * reads.  Because we have to deal with repeat counts, the data item
+ * is always saved after reading, usually in the value[] array.  If a
+ * repeat count is greater than one, we copy the data item multiple
+ * times. */
+
+void
+list_formatted_read (bt type, void *p, int len)
+{
+  char c;
+  int m;
+
+  namelist_mode = 0;
+
+  if (setjmp (g.eof_jump))
+    {
+      generate_error (ERROR_END, NULL);
+      return;
+    }
+
+  if (g.first_item)
+    {
+      g.first_item = 0;
+      input_complete = 0;
+      repeat_count = 1;
+      at_eol = 0;
+
+      c = eat_spaces ();
+      if (is_separator (c))
+	{			/* Found a null value */
+	  eat_separator ();
+	  repeat_count = 0;
+	  if (at_eol)
+            finish_separator ();
+          else
+            return;
+	}
+
+    }
+  else
+    {
+      if (input_complete)
+	return;
+
+      if (repeat_count > 0)
+	{
+	  if (check_type (type, len))
+	    return;
+	  goto set_value;
+	}
+
+      if (at_eol)
+        finish_separator ();
+      else
+        eat_spaces ();
+
+      saved_type = BT_NULL;
+      repeat_count = 1;
+    }
+
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      read_integer (len);
+      break;
+    case BT_LOGICAL:
+      read_logical (len);
+      break;
+    case BT_CHARACTER:
+      read_character (len);
+      break;
+    case BT_REAL:
+      read_real (len);
+      break;
+    case BT_COMPLEX:
+      read_complex (len);
+      break;
+    default:
+      internal_error ("Bad type for list read");
+    }
+
+  if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
+    saved_length = len;
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+set_value:
+  switch (saved_type)
+    {
+    case BT_COMPLEX:
+      len = 2 * len;
+      /* Fall through */
+
+    case BT_INTEGER:
+    case BT_REAL:
+    case BT_LOGICAL:
+      memcpy (p, value, len);
+      break;
+
+    case BT_CHARACTER:
+      m = (len < saved_used) ? len : saved_used;
+      memcpy (p, saved_string, m);
+
+      if (m < len)
+	memset (((char *) p) + m, ' ', len - m);
+      break;
+
+    case BT_NULL:
+      break;
+    }
+
+  if (--repeat_count <= 0)
+    free_saved ();
+}
+
+void
+init_at_eol()
+{
+  at_eol = 0;
+}
+
+/* finish_list_read()-- Finish a list read */
+
+void
+finish_list_read (void)
+{
+  char c;
+
+  free_saved ();
+
+  if (at_eol)
+    {
+      at_eol = 0;
+      return;
+    }
+
+
+  do
+    {
+      c = next_char ();
+    }
+  while (c != '\n');
+}
+
+static namelist_info *
+find_nml_node (char * var_name)
+{
+   namelist_info * t = ionml;
+   while (t != NULL)
+     {
+       if (strcmp (var_name,t->var_name) == 0)
+         {
+           t->value_acquired = 1;
+           return t;
+         }
+       t = t->next;
+     }
+  return NULL;
+}
+
+static void
+match_namelist_name (char *name, int len)
+{
+  int name_len;
+  char c;
+  char * namelist_name = name;
+
+  name_len = 0;
+  /* Match the name of the namelist */
+
+  if (tolower (next_char ()) != tolower (namelist_name[name_len++]))
+    {
+    wrong_name:
+      generate_error (ERROR_READ_VALUE, "Wrong namelist name found");
+      return;
+    }
+
+  while (name_len < len)
+    {
+      c = next_char ();
+      if (tolower (c) != tolower (namelist_name[name_len++]))
+        goto wrong_name;
+    }
+}
+
+
+/********************************************************************
+      Namelist reads
+********************************************************************/
+
+/* namelist_read()-- Process a namelist read.  This subroutine
+ * initializes things, positions to the first element and */
+
+void
+namelist_read (void)
+{
+  char c;
+  int name_matched, next_name ;
+  namelist_info * nl;
+  int len, m;
+  void * p;
+
+  namelist_mode = 1;
+
+  if (setjmp (g.eof_jump))
+    {
+      generate_error (ERROR_END, NULL);
+      return;
+    }
+
+restart:
+  c = next_char ();
+  switch (c)
+    {
+    case ' ':
+      goto restart;
+    case '!':
+      do
+        c = next_char ();
+      while (c != '\n');
+
+      goto restart;
+
+    case '&':
+      break;
+
+    default:
+      generate_error (ERROR_READ_VALUE, "Invalid character in namelist");
+      return;
+    }
+
+  /* Match the name of the namelist */
+  match_namelist_name(ioparm.namelist_name, ioparm.namelist_name_len);
+
+  /* Ready to read namelist elements */
+  for (;;)
+    {
+      c = next_char ();
+      switch (c)
+        {
+        case '&':
+          match_namelist_name("end",3);
+          return;
+        case '\\':
+          return;
+        case ' ':
+        case '\n':
+        case '\t':
+          break;
+        case ',':
+          next_name = 1;
+          break;
+
+        case '=':
+          name_matched = 1;
+          nl = find_nml_node (saved_string);
+          if (nl == NULL)
+            internal_error ("Can not found a valid namelist var!");
+          free_saved();
+
+          len = nl->len;
+          p = nl->mem_pos;
+          switch (nl->type)
+            {
+            case BT_INTEGER:
+              read_integer (len);
+              break;
+            case BT_LOGICAL:
+              read_logical (len);
+              break;
+            case BT_CHARACTER:
+              read_character (len);
+              break;
+            case BT_REAL:
+              read_real (len);
+              break;
+            case BT_COMPLEX:
+              read_complex (len);
+              break;
+            default:
+              internal_error ("Bad type for namelist read");
+            }
+
+           switch (saved_type)
+            {
+            case BT_COMPLEX:
+              len = 2 * len;
+              /* Fall through */
+
+            case BT_INTEGER:
+            case BT_REAL:
+            case BT_LOGICAL:
+              memcpy (p, value, len);
+              break;
+
+            case BT_CHARACTER:
+              m = (len < saved_used) ? len : saved_used;
+              memcpy (p, saved_string, m);
+
+              if (m < len)
+                memset (((char *) p) + m, ' ', len - m);
+              break;
+
+            case BT_NULL:
+              break;
+            }
+
+          break;
+
+        default :
+          push_char(c);
+          break;
+        }
+   }
+}
+
diff --git a/libgfortran/io/lock.c b/libgfortran/io/lock.c
new file mode 100644
index 0000000..1d3f069
--- /dev/null
+++ b/libgfortran/io/lock.c
@@ -0,0 +1,84 @@
+/* Thread/recursion locking
+   Copyright 2002 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org> and Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Libgfor is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+st_parameter ioparm;
+namelist_info * ionml;
+global_t g;
+
+
+/* library_start()-- Called with a library call is entered.  */
+
+void
+library_start (void)
+{
+
+  if (g.in_library)
+    internal_error ("Recursive library calls not allowed");
+
+/* The in_library flag indicates whether we're currently processing a
+ * library call.  Some calls leave immediately, but READ and WRITE
+ * processing return control to the caller but are still considered to
+ * stay within the library. */
+
+  g.in_library = 1;
+
+  if (ioparm.iostat != NULL && ioparm.library_return == LIBRARY_OK)
+    *ioparm.iostat = ERROR_OK;
+
+  ioparm.library_return = LIBRARY_OK;
+}
+
+
+/* library_end()-- Called when a library call is complete in order to
+ * clean up for the next call. */
+
+void
+library_end (void)
+{
+  int t;
+  namelist_info * t1, *t2;
+
+  g.in_library = 0;
+  filename = NULL;
+  line = 0;
+
+  t = ioparm.library_return;
+  if (ionml != NULL)
+    {
+      t1 = ionml;
+      while (t1 != NULL)
+       {
+         t2 = t1;
+         t1 = t1->next;
+         free_mem (t2);
+       }
+    }
+  
+  ionml = NULL;
+  memset (&ioparm, '\0', sizeof (ioparm));
+  ioparm.library_return = t;
+}
+
diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
new file mode 100644
index 0000000..e6fa50d
--- /dev/null
+++ b/libgfortran/io/open.c
@@ -0,0 +1,528 @@
+
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+static st_option access_opt[] = {
+  {"sequential", ACCESS_SEQUENTIAL},
+  {"direct", ACCESS_DIRECT},
+  {NULL}
+}, action_opt[] =
+{
+  {
+  "read", ACTION_READ}
+  ,
+  {
+  "write", ACTION_WRITE}
+  ,
+  {
+  "readwrite", ACTION_READWRITE}
+  ,
+  {
+  NULL}
+}
+
+, blank_opt[] =
+{
+  {
+  "null", BLANK_NULL}
+  ,
+  {
+  "zero", BLANK_ZERO}
+  ,
+  {
+  NULL}
+}
+
+, delim_opt[] =
+{
+  {
+  "none", DELIM_NONE}
+  ,
+  {
+  "apostrophe", DELIM_APOSTROPHE}
+  ,
+  {
+  "quote", DELIM_QUOTE}
+  ,
+  {
+  NULL}
+}
+
+, form_opt[] =
+{
+  {
+  "formatted", FORM_FORMATTED}
+  ,
+  {
+  "unformatted", FORM_UNFORMATTED}
+  ,
+  {
+  NULL}
+}
+
+, position_opt[] =
+{
+  {
+  "asis", POSITION_ASIS}
+  ,
+  {
+  "rewind", POSITION_REWIND}
+  ,
+  {
+  "append", POSITION_APPEND}
+  ,
+  {
+  NULL}
+}
+
+, status_opt[] =
+{
+  {
+  "unknown", STATUS_UNKNOWN}
+  ,
+  {
+  "old", STATUS_OLD}
+  ,
+  {
+  "new", STATUS_NEW}
+  ,
+  {
+  "replace", STATUS_REPLACE}
+  ,
+  {
+  "scratch", STATUS_SCRATCH}
+  ,
+  {
+  NULL}
+}
+
+, pad_opt[] =
+{
+  {
+  "yes", PAD_YES}
+  ,
+  {
+  "no", PAD_NO}
+  ,
+  {
+  NULL}
+};
+
+
+/* test_endfile()-- Given a unit, test to see if the file is
+ * positioned at the terminal point, and if so, change state from
+ * NO_ENDFILE flag to AT_ENDFILE.  This prevents us from changing the
+ * state from AFTER_ENDFILE to AT_ENDFILE. */
+
+void
+test_endfile (unit_t * u)
+{
+
+  if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
+    u->endfile = AT_ENDFILE;
+}
+
+
+/* edit_modes()-- Change the modes of a file, those that are allowed
+ * to be changed. */
+
+static void
+edit_modes (unit_t * u, unit_flags * flags)
+{
+
+  /* Complain about attempts to change the unchangeable */
+
+  if (flags->status != STATUS_UNSPECIFIED &&
+      u->flags.status != flags->position)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change STATUS parameter in OPEN statement");
+
+  if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change ACCESS parameter in OPEN statement");
+
+  if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change FORM parameter in OPEN statement");
+
+  if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change RECL parameter in OPEN statement");
+
+  if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change ACTION parameter in OPEN statement");
+
+  /* Status must be OLD if present */
+
+  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD)
+    generate_error (ERROR_BAD_OPTION,
+		    "OPEN statement must have a STATUS of OLD");
+
+  if (u->flags.form == FORM_UNFORMATTED)
+    {
+      if (flags->delim != DELIM_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"DELIM parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->blank != BLANK_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"BLANK parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->pad != PAD_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"PAD paramter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+    }
+
+  if (ioparm.library_return == LIBRARY_OK)
+    {				/* Change the changeable */
+      if (flags->blank != BLANK_UNSPECIFIED)
+	u->flags.blank = flags->blank;
+      if (flags->delim != DELIM_UNSPECIFIED)
+	u->flags.delim = flags->delim;
+      if (flags->pad != PAD_UNSPECIFIED)
+	u->flags.pad = flags->pad;
+    }
+
+  /* Reposition the file if necessary. */
+
+  switch (flags->position)
+    {
+    case POSITION_UNSPECIFIED:
+    case POSITION_ASIS:
+      break;
+
+    case POSITION_REWIND:
+      if (sseek (u->s, 0) == FAILURE)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->last_record = 0;
+
+      test_endfile (u);		/* We might be at the end */
+      break;
+
+    case POSITION_APPEND:
+      if (sseek (u->s, file_length (u->s)) == FAILURE)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->endfile = AT_ENDFILE;	/* We are at the end */
+      break;
+
+    seek_error:
+      generate_error (ERROR_OS, NULL);
+      break;
+    }
+}
+
+
+/* new_unit()-- Open an unused unit */
+
+void
+new_unit (unit_flags * flags)
+{
+  unit_t *u;
+  stream *s;
+  char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
+
+  /* Change unspecifieds to defaults */
+
+  if (flags->access == ACCESS_UNSPECIFIED)
+    flags->access = ACCESS_SEQUENTIAL;
+
+  if (flags->action == ACTION_UNSPECIFIED)
+    flags->action = ACTION_READWRITE;	/* Processor dependent */
+
+  if (flags->form == FORM_UNSPECIFIED)
+    flags->form = (flags->access == ACCESS_SEQUENTIAL)
+      ? FORM_FORMATTED : FORM_UNFORMATTED;
+
+
+  if (flags->delim == DELIM_UNSPECIFIED)
+    flags->delim = DELIM_NONE;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "DELIM parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->blank == BLANK_UNSPECIFIED)
+    flags->blank = BLANK_NULL;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "BLANK parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->pad == PAD_UNSPECIFIED)
+    flags->pad = PAD_YES;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "PAD paramter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
+   {
+     generate_error (ERROR_OPTION_CONFLICT,
+                     "ACCESS parameter conflicts with SEQUENTIAL access in "
+                     "OPEN statement");
+     goto cleanup;
+   }
+  else
+   if (flags->position == POSITION_UNSPECIFIED)
+     flags->position = POSITION_ASIS;
+
+
+  if (flags->status == STATUS_UNSPECIFIED)
+    flags->status = STATUS_UNKNOWN;
+
+  /* Checks */
+
+  if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0)
+    {
+      generate_error (ERROR_MISSING_OPTION,
+		      "Missing RECL parameter in OPEN statement");
+      goto cleanup;
+    }
+
+  if (ioparm.recl_in != 0 && ioparm.recl_in <= 0)
+    {
+      generate_error (ERROR_BAD_OPTION,
+		      "RECL parameter is non-positive in OPEN statement");
+      goto cleanup;
+    }
+
+  switch (flags->status)
+    {
+    case STATUS_SCRATCH:
+      if (ioparm.file == NULL)
+	break;
+
+      generate_error (ERROR_BAD_OPTION,
+		      "FILE parameter must not be present in OPEN statement");
+      return;
+
+    case STATUS_OLD:
+    case STATUS_NEW:
+    case STATUS_REPLACE:
+    case STATUS_UNKNOWN:
+      if (ioparm.file != NULL)
+	break;
+
+      ioparm.file = tmpname;
+      ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit);
+      break;
+
+    default:
+      internal_error ("new_unit(): Bad status");
+    }
+
+  /* Make sure the file isn't already open someplace else */
+
+  if (find_file () != NULL)
+    {
+      generate_error (ERROR_ALREADY_OPEN, NULL);
+      goto cleanup;
+    }
+
+  /* Open file */
+
+  s = open_external (flags->action, flags->status);
+  if (s == NULL)
+    {
+      generate_error (ERROR_OS, NULL);
+      goto cleanup;
+    }
+
+  if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
+    flags->status = STATUS_OLD;
+
+  /* Create the unit structure */
+
+  u = get_mem (sizeof (unit_t) + ioparm.file_len);
+
+  u->unit_number = ioparm.unit;
+  u->s = s;
+  u->flags = *flags;
+
+  /* Unspecified recl ends up with a processor dependent value */
+
+  u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : DEFAULT_RECL;
+  u->last_record = 0;
+  u->current_record = 0;
+
+  /* If the file is direct access, calculate the maximum record number
+   * via a division now instead of letting the multiplication overflow
+   * later. */
+
+  if (flags->access == ACCESS_DIRECT)
+    u->maxrec = g.max_offset / u->recl;
+
+  memmove (u->file, ioparm.file, ioparm.file_len);
+  u->file_len = ioparm.file_len;
+
+  insert_unit (u);
+
+  /* The file is now connected.  Errors after this point leave the
+   * file connected.  Curiously, the standard requires that the
+   * position specifier be ignored for new files so a newly connected
+   * file starts out that the initial point.  We still need to figure
+   * out if the file is at the end or not. */
+
+  test_endfile (u);
+
+cleanup:
+
+  /* Free memory associated with a temporary filename */
+
+  if (flags->status == STATUS_SCRATCH)
+    free_mem (ioparm.file);
+}
+
+
+/* already_open()-- Open a unit which is already open.  This involves
+ * changing the modes or closing what is there now and opening the new
+ * file. */
+
+static void
+already_open (unit_t * u, unit_flags * flags)
+{
+
+  if (ioparm.file == NULL)
+    {
+      edit_modes (u, flags);
+      return;
+    }
+
+  /* If the file is connected to something else, close it and open a
+   * new unit */
+
+  if (!compare_file_filename (u->s, ioparm.file, ioparm.file_len))
+    {
+      if (close_unit (u))
+	{
+	  generate_error (ERROR_OS, "Error closing file in OPEN statement");
+	  return;
+	}
+
+      new_unit (flags);
+      return;
+    }
+
+  edit_modes (u, flags);
+}
+
+
+/*************/
+/* open file */
+
+void
+st_open (void)
+{
+  unit_flags flags;
+  unit_t *u = NULL;
+ 
+  library_start ();
+
+  /* Decode options */
+
+  flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED :
+    find_option (ioparm.access, ioparm.access_len, access_opt,
+		 "Bad ACCESS parameter in OPEN statement");
+
+  flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED :
+    find_option (ioparm.action, ioparm.action_len, action_opt,
+		 "Bad ACTION parameter in OPEN statement");
+
+  flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED :
+    find_option (ioparm.blank, ioparm.blank_len, blank_opt,
+		 "Bad BLANK parameter in OPEN statement");
+
+  flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED :
+    find_option (ioparm.delim, ioparm.delim_len, delim_opt,
+		 "Bad DELIM parameter in OPEN statement");
+
+  flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED :
+    find_option (ioparm.pad, ioparm.pad_len, pad_opt,
+		 "Bad PAD parameter in OPEN statement");
+
+  flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED :
+    find_option (ioparm.form, ioparm.form_len, form_opt,
+		 "Bad FORM parameter in OPEN statement");
+
+  flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED :
+    find_option (ioparm.position, ioparm.position_len, position_opt,
+		 "Bad POSITION parameter in OPEN statement");
+
+  flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED :
+    find_option (ioparm.status, ioparm.status_len, status_opt,
+		 "Bad STATUS parameter in OPEN statement");
+
+  if (ioparm.unit < 0)
+    generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+
+  if (flags.position != POSITION_UNSPECIFIED &&
+      u->flags.access == ACCESS_DIRECT)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot use POSITION with direct access files");
+
+  if (flags.position == POSITION_UNSPECIFIED)
+    flags.position = POSITION_ASIS;
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  u = find_unit (ioparm.unit);
+
+  if (u == NULL)
+    new_unit (&flags);
+  else
+    already_open (u, &flags);
+
+  library_end ();
+}
diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c
new file mode 100644
index 0000000..3ce9f1d
--- /dev/null
+++ b/libgfortran/io/read.c
@@ -0,0 +1,793 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+#include "config.h"
+#include <string.h>
+#include <errno.h>
+#include <ctype.h>
+#include <stdlib.h>
+#include "libgfortran.h"
+#include "io.h"
+
+/* read.c -- Deal with formatted reads */
+
+/* set_integer()-- All of the integer assignments come here to
+ * actually place the value into memory.  */
+
+void
+set_integer (void *dest, int64_t value, int length)
+{
+
+  switch (length)
+    {
+    case 8:
+      *((int64_t *) dest) = value;
+      break;
+    case 4:
+      *((int32_t *) dest) = value;
+      break;
+    case 2:
+      *((int16_t *) dest) = value;
+      break;
+    case 1:
+      *((int8_t *) dest) = value;
+      break;
+    default:
+      internal_error ("Bad integer kind");
+    }
+}
+
+
+/* max_value()-- Given a length (kind), return the maximum signed or
+ * unsigned value */
+
+uint64_t
+max_value (int length, int signed_flag)
+{
+  uint64_t value;
+
+  switch (length)
+    {
+    case 8:
+      value = signed_flag ? 0x7fffffffffffffff : 0xffffffffffffffff;
+      break;
+    case 4:
+      value = signed_flag ? 0x7fffffff : 0xffffffff;
+      break;
+    case 2:
+      value = signed_flag ? 0x7fff : 0xffff;
+      break;
+    case 1:
+      value = signed_flag ? 0x7f : 0xff;
+      break;
+    default:
+      internal_error ("Bad integer kind");
+    }
+
+  return value;
+}
+
+
+/* convert_real()-- Convert a character representation of a floating
+ * point number to the machine number.  Returns nonzero if there is a
+ * range problem during conversion.  TODO: handle not-a-numbers and
+ * infinities.  Handling of kind 4 is probably wrong because of double
+ * rounding. */
+
+int
+convert_real (void *dest, const char *buffer, int length)
+{
+
+  errno = 0;
+
+  switch (length)
+    {
+    case 4:
+      *((float *) dest) = (float) strtod (buffer, NULL);
+      break;
+    case 8:
+      *((double *) dest) = strtod (buffer, NULL);
+      break;
+    default:
+      internal_error ("Bad real number kind");
+    }
+
+  if (errno != 0)
+    {
+      generate_error (ERROR_READ_VALUE,
+		      "Range error during floating point read");
+      return 1;
+    }
+
+  return 0;
+}
+
+static int
+convert_precision_real (void *dest, int sign,
+                       char *buffer, int length, int exponent)
+{
+  int w, new_dp_pos, i, slen, k, dp;
+  char * p, c;
+  double fval;
+  float tf;
+
+  fval =0.0;
+  tf = 0.0;
+  dp = 0;
+  new_dp_pos = 0;
+
+  slen = strlen (buffer);
+  w = slen;
+  p = buffer;
+
+/*  for (i = w - 1; i > 0; i --)
+    {
+       if (buffer[i] == '0' || buffer[i] == 0)
+         buffer[i] = 0;
+       else
+         break;
+    }
+*/
+  for (i = 0; i < w; i++)
+    {
+       if (buffer[i] == '.')
+         break;
+    }
+
+  new_dp_pos = i;
+  new_dp_pos += exponent;
+
+  while (w > 0)
+    {
+      c = *p;
+      switch (c)
+        {
+        case '0':
+        case '1':
+        case '2':
+        case '3':
+        case '4':
+        case '5':
+        case '6':
+        case '7':
+        case '8':
+        case '9':
+          fval = fval * 10.0 + c - '0';
+          p++;
+          w--;
+          break;
+
+        case '.':
+          dp = 1;
+          p++;
+          w--;
+          break;
+
+       default:
+          p++;
+          w--;
+          break;
+     }
+  }
+
+  if (sign)
+    fval = - fval;
+
+  i = new_dp_pos - slen + dp;
+  k = abs(i);
+  tf = 1.0;
+
+  while (k > 0)
+    {
+       tf *= 10.0 ;
+       k -- ;
+    }
+
+  if (fval != 0.0)
+    {
+       if (i < 0)
+         {
+           fval = fval / tf;
+         }
+        else
+         {
+           fval = fval * tf;
+         }
+    }
+
+  switch (length)
+    {
+    case 4:
+      *((float *) dest) = (float)fval;
+      break;
+    case 8:
+      *((double *) dest) = fval;
+      break;
+    default:
+      internal_error ("Bad real number kind");
+    }
+
+  return 0;
+}
+
+
+/* read_l()-- Read a logical value */
+
+void
+read_l (fnode * f, char *dest, int length)
+{
+  char *p;
+  int w;
+
+  w = f->u.w;
+  p = read_block (&w);
+  if (p == NULL)
+    return;
+
+  while (*p == ' ')
+    {
+      if (--w == 0)
+	goto bad;
+      p++;
+    }
+
+  if (*p == '.')
+    {
+      if (--w == 0)
+	goto bad;
+      p++;
+    }
+
+  switch (*p)
+    {
+    case 't':
+    case 'T':
+      set_integer (dest, 1, length);
+      break;
+    case 'f':
+    case 'F':
+      set_integer (dest, 0, length);
+      break;
+    default:
+    bad:
+      generate_error (ERROR_READ_VALUE, "Bad value on logical read");
+      break;
+    }
+}
+
+
+/* read_a()-- Read a character record.  This one is pretty easy. */
+
+void
+read_a (fnode * f, char *p, int length)
+{
+  char *source;
+  int w, m, n;
+
+  w = f->u.w;
+  if (w == -1) /* '(A)' edit descriptor  */
+    w = length;
+
+  source = read_block (&w);
+  if (source == NULL)
+    return;
+  if (w > length)
+     source += (w - length);
+
+  m = (w > length) ? length : w;
+  memcpy (p, source, m);
+
+  n = length - w;
+  if (n > 0)
+    memset (p + m, ' ', n);
+}
+
+
+/* eat_leading_spaces()-- Given a character pointer and a width,
+ * ignore the leading spaces.  */
+
+static char *
+eat_leading_spaces (int *width, char *p)
+{
+
+  for (;;)
+    {
+      if (*width == 0 || *p != ' ')
+	break;
+
+      (*width)--;
+      p++;
+    }
+
+  return p;
+}
+
+
+static char
+next_char (char **p, int *w)
+{
+  char c, *q;
+
+  if (*w == 0)
+    return '\0';
+
+  q = *p;
+  c = *q++;
+  *p = q;
+
+  (*w)--;
+
+  if (c != ' ')
+    return c;
+  if (g.blank_status == BLANK_ZERO)
+    return '0';
+
+  /* At this point, the rest of the field has to be trailing blanks */
+
+  while (*w > 0)
+    {
+      if (*q++ != ' ')
+	return '?';
+      (*w)--;
+    }
+
+  *p = q;
+  return '\0';
+}
+
+
+/* read_decimal()-- Read a decimal integer value.  The values here are
+ * signed values. */
+
+void
+read_decimal (fnode * f, char *dest, int length)
+{
+  unsigned value, maxv, maxv_10;
+  int v, w, negative;
+  char c, *p;
+
+  w = f->u.w;
+  p = read_block (&w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      set_integer (dest, 0, length);
+      return;
+    }
+
+  maxv = max_value (length, 1);
+  maxv_10 = maxv / 10;
+
+  negative = 0;
+  value = 0;
+
+  switch (*p)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      if (--w == 0)
+	goto bad;
+      /* Fall through */
+
+    default:
+      break;
+    }
+
+  /* At this point we have a digit-string */
+  value = 0;
+
+  for (;;)
+    {
+      c = next_char (&p, &w);
+      if (c == '\0')
+	break;
+
+      if (c < '0' || c > '9')
+	goto bad;
+
+      if (value > maxv_10)
+	goto overflow;
+
+      c -= '0';
+      value = 10 * value;
+
+      if (value > maxv - c)
+	goto overflow;
+      value += c;
+    }
+
+  v = (signed int) value;
+  if (negative)
+    v = -v;
+
+  set_integer (dest, v, length);
+  return;
+
+bad:
+  generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+  return;
+
+overflow:
+  generate_error (ERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  return;
+}
+
+
+/* read_radix()-- This function reads values for non-decimal radixes.
+ * The difference here is that we treat the values here as unsigned
+ * values for the purposes of overflow.  If minus sign is present and
+ * the top bit is set, the value will be incorrect. */
+
+void
+read_radix (fnode * f, char *dest, int length, int radix)
+{
+  unsigned value, maxv, maxv_r;
+  int v, w, negative;
+  char c, *p;
+
+  w = f->u.w;
+  p = read_block (&w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      set_integer (dest, 0, length);
+      return;
+    }
+
+  maxv = max_value (length, 0);
+  maxv_r = maxv / radix;
+
+  negative = 0;
+  value = 0;
+
+  switch (*p)
+    {
+    case '-':
+      negative = 1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      if (--w == 0)
+	goto bad;
+      /* Fall through */
+
+    default:
+      break;
+    }
+
+  /* At this point we have a digit-string */
+  value = 0;
+
+  for (;;)
+    {
+      c = next_char (&p, &w);
+      if (c == '\0')
+	break;
+
+      switch (radix)
+	{
+	case 2:
+	  if (c < '0' || c > '1')
+	    goto bad;
+	  break;
+
+	case 8:
+	  if (c < '0' || c > '7')
+	    goto bad;
+	  break;
+
+	case 16:
+	  switch (c)
+	    {
+	    case '0':
+	    case '1':
+	    case '2':
+	    case '3':
+	    case '4':
+	    case '5':
+	    case '6':
+	    case '7':
+	    case '8':
+	    case '9':
+	      break;
+
+	    case 'a':
+	    case 'b':
+	    case 'c':
+	    case 'd':
+	    case 'e':
+	      c = c - 'a' + '9' + 1;
+	      break;
+
+	    case 'A':
+	    case 'B':
+	    case 'C':
+	    case 'D':
+	    case 'E':
+	      c = c - 'A' + '9' + 1;
+	      break;
+
+	    default:
+	      goto bad;
+	    }
+
+	  break;
+	}
+
+      if (value > maxv_r)
+	goto overflow;
+
+      c -= '0';
+      value = radix * value;
+
+      if (maxv - c < value)
+	goto overflow;
+      value += c;
+    }
+
+  v = (signed int) value;
+  if (negative)
+    v = -v;
+
+  set_integer (dest, v, length);
+  return;
+
+bad:
+  generate_error (ERROR_READ_VALUE, "Bad value during integer read");
+  return;
+
+overflow:
+  generate_error (ERROR_READ_OVERFLOW,
+		  "Value overflowed during integer read");
+  return;
+}
+
+
+/* read_f()-- Read a floating point number with F-style editing, which
+ * is what all of the other floating point descriptors behave as.  The
+ * tricky part is that optional spaces are allowed after an E or D,
+ * and the implicit decimal point if a decimal point is not present in
+ * the input. */
+
+void
+read_f (fnode * f, char *dest, int length)
+{
+  int w, seen_dp, exponent;
+  int exponent_sign, val_sign;
+  char *p, *buffer, *n;
+
+  val_sign = 0;
+  seen_dp = 0;
+  w = f->u.w;
+  p = read_block (&w);
+  if (p == NULL)
+    return;
+
+  p = eat_leading_spaces (&w, p);
+  if (w == 0)
+    {
+      switch (length)
+	{
+	case 4:
+	  *((float *) dest) = 0.0;
+	  break;
+
+	case 8:
+	  *((double *) dest) = 0.0;
+	  break;
+	}
+
+      return;
+    }
+
+  if (w + 2 < SCRATCH_SIZE)
+    buffer = scratch;
+  else
+    buffer = get_mem (w + 2);
+
+  memset(buffer, 0, w + 2);
+
+  n = buffer;
+
+  /* Optional sign */
+
+  if (*p == '-' || *p == '+')
+    {
+      if (*p == '-')
+        val_sign = 1;
+      p++;
+
+      if (--w == 0)
+	goto bad_float;
+    }
+
+  exponent_sign = 1;
+
+  /* A digit (or a '.') is required at this point */
+
+  if (!isdigit (*p) && *p != '.')
+    goto bad_float;
+
+  while (w > 0)
+    {
+      switch (*p)
+	{
+	case '0':
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	  *n++ = *p++;
+	  w--;
+	  break;
+
+	case '.':
+	  if (seen_dp)
+	    goto bad_float;
+	  seen_dp = 1;
+
+	  *n++ = *p++;
+	  w--;
+	  break;
+
+	case ' ':
+	  if (g.blank_status == BLANK_ZERO)
+	    *n++ = '0';
+	  p++;
+	  w--;
+	  break;
+
+	case '-':
+	  exponent_sign = -1;
+	  /* Fall through */
+
+	case '+':
+	  p++;
+	  w--;
+	  goto exp2;
+
+	case 'd':
+	case 'e':
+	case 'D':
+	case 'E':
+	  p++;
+	  w--;
+	  goto exp1;
+
+	default:
+	  goto bad_float;
+	}
+    }
+
+/* No exponent has been seen, so we use the current scale factor */
+
+  exponent = -g.scale_factor;
+  goto done;
+
+bad_float:
+  generate_error (ERROR_READ_VALUE, "Bad value during floating point read");
+  if (buffer != scratch)
+     free_mem (buffer);
+  return;
+
+/* At this point the start of an exponent has been found */
+
+exp1:
+  while (w > 0 && *p == ' ')
+    {
+      w--;
+      p++;
+    }
+
+  switch (*p)
+    {
+    case '-':
+      exponent_sign = -1;
+      /* Fall through */
+
+    case '+':
+      p++;
+      w--;
+      break;
+    }
+
+  if (w == 0)
+    goto bad_float;
+
+/* At this point a digit string is required.  We calculate the value
+ * of the exponent in order to take account of the scale factor and
+ * the d parameter before explict conversion takes place. */
+
+exp2:
+  if (!isdigit (*p))
+    goto bad_float;
+
+  exponent = *p - '0';
+  p++;
+  w--;
+
+  while (w > 0 && isdigit (*p))
+    {
+      exponent = 10 * exponent + *p - '0';
+      if (exponent > 999999)
+	goto bad_float;
+
+      p++;
+      w--;
+    }
+
+  /* Only allow trailing blanks */
+
+  while (w > 0)
+    {
+      if (*p != ' ')
+	goto bad_float;
+      p++;
+      w--;
+    }
+
+  exponent = exponent * exponent_sign;
+
+done:
+  if (!seen_dp)
+    exponent -= f->u.real.d;
+
+  /* The number is syntactically correct and ready for conversion.
+   * The only thing that can go wrong at this point is overflow or
+   * underflow. */
+
+  convert_precision_real (dest, val_sign, buffer, length, exponent);
+
+  if (buffer != scratch)
+     free_mem (buffer);
+
+  return;
+}
+
+
+/* read_x()-- Deal with the X/TR descriptor.  We just read some data
+ * and never look at it. */
+
+void
+read_x (fnode * f)
+{
+  int n;
+
+  n = f->u.n;
+  read_block (&n);
+}
diff --git a/libgfortran/io/rewind.c b/libgfortran/io/rewind.c
new file mode 100644
index 0000000..d068853
--- /dev/null
+++ b/libgfortran/io/rewind.c
@@ -0,0 +1,56 @@
+
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include "libgfortran.h"
+#include "io.h"
+
+/* rewind.c--  Implement the rewind statement */
+
+void
+st_rewind (void)
+{
+  unit_t *u;
+
+  library_start ();
+
+  u = find_unit (ioparm.unit);
+  if (u != NULL)
+    {
+      if (u->flags.access != ACCESS_SEQUENTIAL)
+	generate_error (ERROR_BAD_OPTION,
+			"Cannot REWIND a file opened for DIRECT access");
+      else
+	{
+          if (g.mode==WRITING)
+            struncate(u->s);
+	  u->last_record = 0;
+	  if (sseek (u->s, 0) == FAILURE)
+	    generate_error (ERROR_OS, NULL);
+
+	  u->endfile = NO_ENDFILE;
+	  u->current_record = 0;
+	  test_endfile (u);
+	}
+    }
+
+  library_end ();
+}
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
new file mode 100644
index 0000000..b1f0ef1
--- /dev/null
+++ b/libgfortran/io/transfer.c
@@ -0,0 +1,1498 @@
+
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+/* transfer.c -- Top level handling of data transfer statements. */
+
+#include "config.h"
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* Calling conventions:  Data transfer statements are unlike other
+ * library calls in that they extend over several calls.
+
+ * The first call is always a call to st_read() or st_write().  These
+ * subroutines return no status unless a namelist read or write is
+ * being done, in which case there is the usual status.  No further
+ * calls are necessary in this case.
+ *
+ * For other sorts of data transfer, there are zero or more data
+ * transfer statement that depend on the format of the data transfer
+ * statement.
+ *
+ *    transfer_integer
+ *    transfer_logical
+ *    transfer_character
+ *    transfer_real
+ *    transfer_complex
+ *
+ *  These subroutines do not return status.
+ *
+ *  The last call is a call to st_[read|write]_done().  While
+ *  something can easily go wrong with the initial st_read() or
+ *  st_write(), an error inhibits any data from actually being
+ *  transferred.
+ */
+
+unit_t *current_unit;
+static int sf_seen_eor = 0;
+
+char scratch[SCRATCH_SIZE];
+static char *line_buffer = NULL;
+
+static unit_advance advance_status;
+
+static st_option advance_opt[] = {
+  {"yes", ADVANCE_YES},
+  {"no", ADVANCE_NO},
+  {NULL}
+};
+
+
+static void (*transfer) (bt, void *, int);
+
+
+typedef enum
+{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
+  FORMATTED_DIRECT, UNFORMATTED_DIRECT
+}
+file_mode;
+
+
+static file_mode
+current_mode (void)
+{
+  file_mode m;
+
+  if (current_unit->flags.access == ACCESS_DIRECT)
+    {
+      m = current_unit->flags.form == FORM_FORMATTED ?
+	FORMATTED_DIRECT : UNFORMATTED_DIRECT;
+    }
+  else
+    {
+      m = current_unit->flags.form == FORM_FORMATTED ?
+	FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
+    }
+
+  return m;
+}
+
+
+/* Mid level data transfer statements.  These subroutines do reading
+ * and writing in the style of salloc_r()/salloc_w() within the
+ * current record. */
+
+/* read_sf()-- When reading sequential formatted records we have a
+ * problem.  We don't know how long the line is until we read the
+ * trailing newline, and we don't want to read too much.  If we read
+ * too much, we might have to do a physical seek backwards depending
+ * on how much data is present, and devices like terminals aren't
+ * seekable and would cause an I/O error.
+ *
+ * Given this, the solution is to read a byte at a time, stopping if
+ * we hit the newline.  For small locations, we use a static buffer.
+ * For larger allocations, we are forced to allocate memory on the
+ * heap.  Hopefully this won't happen very often. */
+
+static char *
+read_sf (int *length)
+{
+  static char data[SCRATCH_SIZE];
+  char *base, *p, *q;
+  int n, unity;
+
+  if (*length > SCRATCH_SIZE)
+    p = base = line_buffer = get_mem (*length);
+  else
+    p = base = data;
+
+  memset(base,'\0',*length);
+
+  current_unit->bytes_left = options.default_recl;
+  unity = 1;
+  n = 0;
+
+  do
+    {
+      if (is_internal_unit())
+        {
+       /* unity may be modified inside salloc_r if is_internal_unit() is true */
+          unity = 1;
+        }
+
+      q = salloc_r (current_unit->s, &unity);
+      if (q == NULL)
+	break;
+
+      if (*q == '\n')
+	{
+          if (current_unit->unit_number == options.stdin_unit)
+            { 
+              if (n <= 0)
+                continue;
+            }          
+			/* Unexpected end of line */
+	  if (current_unit->flags.pad == PAD_NO)
+	    {
+	      generate_error (ERROR_EOR, NULL);
+	      return NULL;
+	    }
+
+	  current_unit->bytes_left = 0;
+	  *length = n;
+          sf_seen_eor = 1;
+	  break;
+	}
+
+      n++;
+      *p++ = *q;
+      sf_seen_eor = 0;
+    }
+  while (n < *length);
+
+  return base;
+}
+
+
+/* read_block()-- Function for reading the next couple of bytes from
+ * the current file, advancing the current position.  We return a
+ * pointer to a buffer containing the bytes.  We return NULL on end of
+ * record or end of file.
+ *
+ * If the read is short, then it is because the current record does not
+ * have enough data to satisfy the read request and the file was
+ * opened with PAD=YES.  The caller must assume tailing spaces for
+ * short reads.  */
+
+void *
+read_block (int *length)
+{
+  char *source;
+  int nread;
+
+  if (current_unit->flags.form == FORM_FORMATTED &&
+      current_unit->flags.access == ACCESS_SEQUENTIAL)
+    return read_sf (length);	/* Special case */
+
+  if (current_unit->bytes_left < *length)
+    {
+      if (current_unit->flags.pad == PAD_NO)
+	{
+	  generate_error (ERROR_EOR, NULL);	/* Not enough data left */
+	  return NULL;
+	}
+
+      *length = current_unit->bytes_left;
+    }
+
+  current_unit->bytes_left -= *length;
+
+  nread = *length;
+  source = salloc_r (current_unit->s, &nread);
+
+  if (ioparm.size != NULL)
+    *ioparm.size += nread;
+
+  if (nread != *length)
+    {				/* Short read, this shouldn't happen */
+      if (current_unit->flags.pad == PAD_YES)
+	*length = nread;
+      else
+	{
+	  generate_error (ERROR_EOR, NULL);
+	  source = NULL;
+	}
+    }
+
+  return source;
+}
+
+
+/* write_block()-- Function for writing a block of bytes to the
+ * current file at the current position, advancing the file pointer.
+ * We are given a length and return a pointer to a buffer that the
+ * caller must (completely) fill in.  Returns NULL on error. */
+
+void *
+write_block (int length)
+{
+  char *dest;
+
+  if (!is_internal_unit() && current_unit->bytes_left < length)
+    {
+      generate_error (ERROR_EOR, NULL);
+      return NULL;
+    }
+
+  current_unit->bytes_left -= length;
+  dest = salloc_w (current_unit->s, &length);
+
+  if (ioparm.size != NULL)
+    *ioparm.size += length;
+
+  return dest;
+}
+
+
+/* unformatted_read()-- Master function for unformatted reads.  */
+
+static void
+unformatted_read (bt type, void *dest, int length)
+{
+  void *source;
+  int w;
+  w = length;
+  source = read_block (&w);
+
+  if (source != NULL)
+    {
+      memcpy (dest, source, w);
+      if (length != w)
+	memset (((char *) dest) + w, ' ', length - w);
+    }
+}
+
+static void
+unformatted_write (bt type, void *source, int length)
+{
+  void *dest;
+   dest = write_block (length);
+   if (dest != NULL)
+     memcpy (dest, source, length);
+}
+
+
+/* type_name()-- Return a pointer to the name of a type. */
+
+const char *
+type_name (bt type)
+{
+  const char *p;
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      p = "INTEGER";
+      break;
+    case BT_LOGICAL:
+      p = "LOGICAL";
+      break;
+    case BT_CHARACTER:
+      p = "CHARACTER";
+      break;
+    case BT_REAL:
+      p = "REAL";
+      break;
+    case BT_COMPLEX:
+      p = "COMPLEX";
+      break;
+    default:
+      internal_error ("type_name(): Bad type");
+    }
+
+  return p;
+}
+
+
+/* write_constant_string()-- write a constant string to the output.
+ * This is complicated because the string can have doubled delimiters
+ * in it.  The length in the format node is the true length. */
+
+static void
+write_constant_string (fnode * f)
+{
+  char c, delimiter, *p, *q;
+  int length;
+
+  length = f->u.string.length;
+  if (length == 0)
+    return;
+
+  p = write_block (length);
+  if (p == NULL)
+    return;
+
+  q = f->u.string.p;
+  delimiter = q[-1];
+
+  for (; length > 0; length--)
+    {
+      c = *p++ = *q++;
+      if (c == delimiter && c != 'H')
+	q++;			/* Skip the doubled delimiter */
+    }
+}
+
+
+/* require_type()-- Given actual and expected types in a formatted
+ * data transfer, make sure they agree.  If not, an error message is
+ * generated.  Returns nonzero if something went wrong.  */
+
+static int
+require_type (bt expected, bt actual, fnode * f)
+{
+  char buffer[100];
+
+  if (actual == expected)
+    return 0;
+
+  st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
+	      type_name (expected), g.item_count, type_name (actual));
+
+  format_error (f, buffer);
+  return 1;
+}
+
+
+/* formatted_transfer()-- This subroutine is the main loop for a
+ * formatted data transfer statement.  It would be natural to
+ * implement this as a coroutine with the user program, but C makes
+ * that awkward.  We loop, processesing format elements.  When we
+ * actually have to transfer data instead of just setting flags, we
+ * return control to the user program which calls a subroutine that
+ * supplies the address and type of the next element, then comes back
+ * here to process it.  */
+
+static void
+formatted_transfer (bt type, void *p, int len)
+{
+  int pos ,m ;
+  fnode *f;
+  int i, n;
+  int consume_data_flag;
+
+  /* Change a complex data item into a pair of reals */
+
+  n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
+  if (type == BT_COMPLEX)
+    type = BT_REAL;
+
+  /* If reversion has occurred and there is another real data item,
+   * then we have to move to the next record */
+
+  if (g.reversion_flag && n > 0)
+    {
+      g.reversion_flag = 0;
+      next_record (0);
+    }
+  for (;;)
+    {
+      consume_data_flag = 1 ;
+      if (ioparm.library_return != LIBRARY_OK)
+	break;
+
+      f = next_format ();
+      if (f == NULL)
+	return;			/* No data descriptors left (already raised) */
+
+      switch (f->format)
+	{
+	case FMT_I:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_INTEGER, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_decimal (f, p, len);
+	  else
+	    write_i (f, p, len);
+
+	  break;
+
+	case FMT_B:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_INTEGER, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_radix (f, p, len, 2);
+	  else
+	    write_b (f, p, len);
+
+	  break;
+
+	case FMT_O:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (g.mode == READING)
+	    read_radix (f, p, len, 8);
+	  else
+	    write_o (f, p, len);
+
+	  break;
+
+	case FMT_Z:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (g.mode == READING)
+	    read_radix (f, p, len, 16);
+	  else
+	    write_z (f, p, len);
+
+	  break;
+
+	case FMT_A:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_CHARACTER, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_a (f, p, len);
+	  else
+	    write_a (f, p, len);
+
+	  break;
+
+	case FMT_L:
+	  if (n == 0)
+	    goto need_data;
+
+	  if (g.mode == READING)
+	    read_l (f, p, len);
+	  else
+	    write_l (f, p, len);
+
+	  break;
+
+	case FMT_D:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_REAL, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_f (f, p, len);
+	  else
+	    write_d (f, p, len);
+
+	  break;
+
+	case FMT_E:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_REAL, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_f (f, p, len);
+	  else
+	    write_e (f, p, len);
+	  break;
+
+	case FMT_EN:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_REAL, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_f (f, p, len);
+	  else
+	    write_en (f, p, len);
+
+	  break;
+
+	case FMT_ES:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_REAL, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_f (f, p, len);
+	  else
+	    write_es (f, p, len);
+
+	  break;
+
+	case FMT_F:
+	  if (n == 0)
+	    goto need_data;
+	  if (require_type (BT_REAL, type, f))
+	    return;
+
+	  if (g.mode == READING)
+	    read_f (f, p, len);
+	  else
+	    write_f (f, p, len);
+
+	  break;
+
+	case FMT_G:
+	  if (n == 0)
+	    goto need_data;
+	  if (g.mode == READING)
+	    switch (type)
+	      {
+	      case BT_INTEGER:
+		read_decimal (f, p, len);
+		break;
+	      case BT_LOGICAL:
+		read_l (f, p, len);
+		break;
+	      case BT_CHARACTER:
+		read_a (f, p, len);
+		break;
+	      case BT_REAL:
+		read_f (f, p, len);
+		break;
+	      default:
+		goto bad_type;
+	      }
+	  else
+	    switch (type)
+	      {
+	      case BT_INTEGER:
+		write_i (f, p, len);
+		break;
+	      case BT_LOGICAL:
+		write_l (f, p, len);
+		break;
+	      case BT_CHARACTER:
+		write_a (f, p, len);
+		break;
+	      case BT_REAL:
+		write_d (f, p, len);
+		break;
+	      default:
+	      bad_type:
+		internal_error ("formatted_transfer(): Bad type");
+	      }
+
+	  break;
+
+	case FMT_STRING:
+          consume_data_flag = 0 ;
+	  if (g.mode == READING)
+	    {
+	      format_error (f, "Constant string in input format");
+	      return;
+	    }
+	  write_constant_string (f);
+	  break;
+
+	  /* Format codes that don't transfer data */
+	case FMT_X:
+	case FMT_TR:
+          consume_data_flag = 0 ;
+	  if (g.mode == READING)
+	    read_x (f);
+	  else
+	    write_x (f);
+
+	  break;
+
+        case FMT_T:
+           pos = f->u.n ;
+           pos= current_unit->recl - current_unit->bytes_left - pos;
+                         /* fall through */
+
+        case FMT_TL:
+           consume_data_flag = 0 ;
+           pos = f->u.n ;
+
+           if (pos < 0 || pos >= current_unit->recl )
+           {
+             generate_error (ERROR_EOR, "T Or TL edit position error");
+             break ;
+            }
+            m = pos - (current_unit->recl - current_unit->bytes_left);
+
+            if (m == 0)
+               break;
+
+            if (m > 0)
+             {
+               f->u.n = m;
+               if (g.mode == READING)
+                 read_x (f);
+               else
+                 write_x (f);
+             }
+            if (m < 0)
+             {
+               move_pos_offset (current_unit->s,m);
+             }
+
+	  break;
+
+	case FMT_S:
+          consume_data_flag = 0 ;
+	  g.sign_status = SIGN_S;
+	  break;
+
+	case FMT_SS:
+          consume_data_flag = 0 ;
+	  g.sign_status = SIGN_SS;
+	  break;
+
+	case FMT_SP:
+          consume_data_flag = 0 ;
+	  g.sign_status = SIGN_SP;
+	  break;
+
+	case FMT_BN:
+          consume_data_flag = 0 ;
+	  g.blank_status = BLANK_NULL;
+	  break;
+
+	case FMT_BZ:
+          consume_data_flag = 0 ;
+	  g.blank_status = BLANK_ZERO;
+	  break;
+
+	case FMT_P:
+          consume_data_flag = 0 ;
+	  g.scale_factor = f->u.k;
+	  break;
+
+	case FMT_DOLLAR:
+          consume_data_flag = 0 ;
+	  g.seen_dollar = 1;
+	  break;
+
+	case FMT_SLASH:
+          consume_data_flag = 0 ;
+	  for (i = 0; i < f->repeat; i++)
+	    next_record (0);
+
+	  break;
+
+	case FMT_COLON:
+	  /* A colon descriptor causes us to exit this loop (in particular
+	   * preventing another / descriptor from being processed) unless there
+	   * is another data item to be transferred. */
+          consume_data_flag = 0 ;
+	  if (n == 0)
+	    return;
+	  break;
+
+	default:
+	  internal_error ("Bad format node");
+	}
+
+      /* Free a buffer that we had to allocate during a sequential
+       * formatted read of a block that was larger than the static
+       * buffer. */
+
+      if (line_buffer != NULL)
+	{
+	  free_mem (line_buffer);
+	  line_buffer = NULL;
+	}
+
+      /* Adjust the item count and data pointer */
+
+      if ((consume_data_flag > 0) && (n > 0))
+      {
+	n--;
+        p = ((char *) p) + len;
+      }
+    }
+
+  return;
+
+/* Come here when we need a data descriptor but don't have one.  We
+ * push the current format node back onto the input, then return and
+ * let the user program call us back with the data. */
+
+need_data:
+  unget_format (f);
+}
+
+
+
+/* Data transfer entry points.  The type of the data entity is
+ * implicit in the subroutine call.  This prevents us from having to
+ * share a common enum with the compiler. */
+
+void
+transfer_integer (void *p, int kind)
+{
+
+  g.item_count++;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+  transfer (BT_INTEGER, p, kind);
+}
+
+
+void
+transfer_real (void *p, int kind)
+{
+
+  g.item_count++;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+  transfer (BT_REAL, p, kind);
+}
+
+
+void
+transfer_logical (void *p, int kind)
+{
+
+  g.item_count++;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+  transfer (BT_LOGICAL, p, kind);
+}
+
+
+void
+transfer_character (void *p, int len)
+{
+
+  g.item_count++;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+  transfer (BT_CHARACTER, p, len);
+}
+
+
+void
+transfer_complex (void *p, int kind)
+{
+
+  g.item_count++;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+  transfer (BT_COMPLEX, p, kind);
+}
+
+
+/* us_read()-- Preposition a sequential unformatted file while reading. */
+
+static void
+us_read (void)
+{
+  offset_t *p;
+  int n;
+
+  n = sizeof (offset_t);
+  p = (offset_t *) salloc_r (current_unit->s, &n);
+
+  if (p == NULL || n != sizeof (offset_t))
+    {
+      generate_error (ERROR_BAD_US, NULL);
+      return;
+    }
+
+  current_unit->bytes_left = *p;
+}
+
+
+/* us_write()-- Preposition a sequential unformatted file while
+ * writing.  This amount to writing a bogus length that will be filled
+ * in later.  */
+
+static void
+us_write (void)
+{
+  offset_t *p;
+  int length;
+
+  length = sizeof (offset_t);
+  p = (offset_t *) salloc_w (current_unit->s, &length);
+
+  if (p == NULL)
+    {
+      generate_error (ERROR_OS, NULL);
+      return;
+    }
+
+  *p = 0;			/* Bogus value for now */
+  if (sfree (current_unit->s) == FAILURE)
+    generate_error (ERROR_OS, NULL);
+
+  current_unit->bytes_left = current_unit->recl;
+}
+
+
+/* pre_position()-- position to the next record prior to transfer.  We
+ * are assumed to be before the next record.  We also calculate the
+ * bytes in the next record. */
+
+static void
+pre_position (void)
+{
+
+  if (current_unit->current_record)
+    return;			/* Already positioned */
+
+  switch (current_mode ())
+    {
+    case UNFORMATTED_SEQUENTIAL:
+      if (g.mode == READING)
+	us_read ();
+      else
+	us_write ();
+
+      break;
+
+    case FORMATTED_SEQUENTIAL:
+    case FORMATTED_DIRECT:
+    case UNFORMATTED_DIRECT:
+      current_unit->bytes_left = current_unit->recl;
+      break;
+    }
+
+  current_unit->current_record = 1;
+}
+
+
+/* data_transfer_init()-- Initialize things for a data transfer.  This
+ * code is common for both reading and writing. */
+
+static void
+data_transfer_init (int read_flag)
+{
+  unit_flags u_flags;  /* used for creating a unit if needed */
+
+  g.mode = read_flag ? READING : WRITING;
+
+  if (ioparm.size != NULL)
+    *ioparm.size = 0;		/* Initialize the count */
+
+  current_unit = get_unit (read_flag);
+  if (current_unit == NULL)
+  {  /* open the unit with some default flags */
+     memset (&u_flags, '\0', sizeof (u_flags));
+     u_flags.access = ACCESS_SEQUENTIAL;
+     u_flags.action = ACTION_READWRITE;
+     u_flags.form = FORM_UNSPECIFIED;
+     u_flags.delim = DELIM_UNSPECIFIED;
+     u_flags.blank = BLANK_UNSPECIFIED;
+     u_flags.pad = PAD_UNSPECIFIED;
+     u_flags.status = STATUS_UNKNOWN;
+     new_unit(&u_flags);
+     current_unit = get_unit (read_flag);
+  }
+
+  if (current_unit == NULL)
+    return;
+
+  if (is_internal_unit() && g.mode==WRITING)
+    empty_internal_buffer (current_unit->s);
+
+  /* Check the action */
+
+  if (read_flag && current_unit->flags.action == ACTION_WRITE)
+    generate_error (ERROR_BAD_ACTION,
+		    "Cannot read from file opened for WRITE");
+
+  if (!read_flag && current_unit->flags.action == ACTION_READ)
+    generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  /* Check the format */
+
+  if (ioparm.format)
+    parse_format ();
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  if (current_unit->flags.form == FORM_UNFORMATTED
+      && (ioparm.format != NULL || ioparm.list_format))
+    generate_error (ERROR_OPTION_CONFLICT,
+		    "Format present for UNFORMATTED data transfer");
+
+  if (ioparm.namelist_name != NULL && ionml != NULL)
+     {
+        if(ioparm.format != NULL)
+           generate_error (ERROR_OPTION_CONFLICT,
+                    "A format cannot be specified with a namelist");
+     }
+  else if (current_unit->flags.form == FORM_FORMATTED &&
+           ioparm.format == NULL && !ioparm.list_format)
+    generate_error (ERROR_OPTION_CONFLICT,
+                    "Missing format for FORMATTED data transfer");
+
+
+  if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
+    generate_error (ERROR_OPTION_CONFLICT,
+		    "Internal file cannot be accessed by UNFORMATTED data transfer");
+
+  /* Check the record number */
+
+  if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
+    {
+      generate_error (ERROR_MISSING_OPTION,
+		      "Direct access data transfer requires record number");
+      return;
+    }
+
+  if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
+    {
+      generate_error (ERROR_OPTION_CONFLICT,
+		      "Record number not allowed for sequential access data transfer");
+      return;
+    }
+
+  /* Process the ADVANCE option */
+
+  advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
+    find_option (ioparm.advance, ioparm.advance_len, advance_opt,
+		 "Bad ADVANCE parameter in data transfer statement");
+
+  if (advance_status != ADVANCE_UNSPECIFIED)
+    {
+      if (current_unit->flags.access == ACCESS_DIRECT)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"ADVANCE specification conflicts with sequential access");
+
+      if (is_internal_unit ())
+	generate_error (ERROR_OPTION_CONFLICT,
+			"ADVANCE specification conflicts with internal file");
+
+      if (ioparm.format == NULL || ioparm.list_format)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"ADVANCE specification requires an explicit format");
+    }
+
+  if (read_flag)
+    {
+      if (ioparm.eor != 0 && advance_status == ADVANCE_NO)
+	generate_error (ERROR_MISSING_OPTION,
+			"EOR specification requires an ADVANCE specification of NO");
+
+      if (ioparm.size != NULL && advance_status != ADVANCE_NO)
+	generate_error (ERROR_MISSING_OPTION,
+			"SIZE specification requires an ADVANCE specification of NO");
+
+    }
+  else
+    {				/* Write constraints */
+
+      if (ioparm.end != 0)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"END specification cannot appear in a write statement");
+
+      if (ioparm.eor != 0)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"EOR specification cannot appear in a write statement");
+
+      if (ioparm.size != 0)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"SIZE specification cannot appear in a write statement");
+    }
+
+  if (advance_status == ADVANCE_UNSPECIFIED)
+    advance_status = ADVANCE_YES;
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  /* Sanity checks on the record number */
+
+  if (ioparm.rec)
+    {
+      if (ioparm.rec <= 0)
+	{
+	  generate_error (ERROR_BAD_OPTION, "Record number must be positive");
+	  return;
+	}
+
+      if (ioparm.rec >= current_unit->maxrec)
+	{
+	  generate_error (ERROR_BAD_OPTION, "Record number too large");
+	  return;
+	}
+
+      /* Position the file */
+
+      if (sseek (current_unit->s,
+               (ioparm.rec - 1) * current_unit->recl) == FAILURE)
+	generate_error (ERROR_OS, NULL);
+    }
+
+  /* Set the initial value of flags */
+
+  g.blank_status = current_unit->flags.blank;
+  g.sign_status = SIGN_S;
+  g.scale_factor = 0;
+  g.seen_dollar = 0;
+  g.first_item = 1;
+  g.item_count = 0;
+
+  pre_position ();
+
+  /* Set up the subroutine that will handle the transfers */
+
+  if (read_flag)
+    {
+      if (current_unit->flags.form == FORM_UNFORMATTED)
+	transfer = unformatted_read;
+      else
+	{
+	  if (ioparm.list_format)
+            {
+               transfer = list_formatted_read;
+               init_at_eol();
+            }
+	  else
+	    transfer = formatted_transfer;
+	}
+    }
+  else
+    {
+      if (current_unit->flags.form == FORM_UNFORMATTED)
+	transfer = unformatted_write;
+      else
+	{
+	  if (ioparm.list_format)
+	    transfer = list_formatted_write;
+	  else
+	    transfer = formatted_transfer;
+	}
+    }
+
+  /* Make sure that we don't do a read after a nonadvancing write */
+
+  if (read_flag)
+    {
+      if (current_unit->read_bad)
+	{
+	  generate_error (ERROR_BAD_OPTION,
+			  "Cannot READ after a nonadvancing WRITE");
+	  return;
+	}
+    }
+  else
+    {
+      if (advance_status == ADVANCE_YES)
+	current_unit->read_bad = 1;
+    }
+
+  /* Start the data transfer if we are doing a formatted transfer */
+  if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
+      && ioparm.namelist_name == NULL && ionml == NULL)
+
+     formatted_transfer (0, NULL, 0);
+
+}
+
+
+/* next_record_r()-- Space to the next record for read mode.  If the
+ * file is not seekable, we read MAX_READ chunks until we get to the
+ * right position. */
+
+#define MAX_READ 4096
+
+static void
+next_record_r (int done)
+{
+  int rlength, length;
+  offset_t new;
+  char *p;
+
+  switch (current_mode ())
+    {
+    case UNFORMATTED_SEQUENTIAL:
+      current_unit->bytes_left += sizeof (offset_t);	/* Skip over tail */
+
+      /* Fall through */
+
+    case FORMATTED_DIRECT:
+    case UNFORMATTED_DIRECT:
+      if (current_unit->bytes_left == 0)
+	break;
+
+      if (is_seekable (current_unit->s))
+	{
+	  new = file_position (current_unit->s) + current_unit->bytes_left;
+
+	  /* Direct access files do not generate END conditions, only I/O errors */
+
+	  if (sseek (current_unit->s, new) == FAILURE)
+	    generate_error (ERROR_OS, NULL);
+
+	}
+      else
+	{			/* Seek by reading data */
+	  while (current_unit->bytes_left > 0)
+	    {
+	      rlength = length = (MAX_READ > current_unit->bytes_left) ?
+		MAX_READ : current_unit->bytes_left;
+
+	      p = salloc_r (current_unit->s, &rlength);
+	      if (p == NULL)
+		{
+		  generate_error (ERROR_OS, NULL);
+		  break;
+		}
+
+	      current_unit->bytes_left -= length;
+	    }
+	}
+
+      break;
+
+    case FORMATTED_SEQUENTIAL:
+      length = 1;
+      if (sf_seen_eor && done)
+         break;
+
+      do
+        {
+          p = salloc_r (current_unit->s, &length);
+
+          /*In case of internal file, there may not be any '\n'.*/
+          if (is_internal_unit() && p == NULL)
+            {
+               break;
+            }
+
+          if (p == NULL)
+            {
+              generate_error (ERROR_OS, NULL);
+              break;
+            }
+
+          if (length == 0)
+            {
+              current_unit->endfile = AT_ENDFILE;
+              break;
+            }
+        }
+      while (*p != '\n');
+
+      break;
+    }
+
+  if (current_unit->flags.access == ACCESS_SEQUENTIAL)
+    test_endfile (current_unit);
+}
+
+
+/* next_record_w()-- Position to the next record in write mode */
+
+static void
+next_record_w (int done)
+{
+  offset_t c, m;
+  int length;
+  char *p;
+
+  switch (current_mode ())
+    {
+    case FORMATTED_DIRECT:
+    case UNFORMATTED_DIRECT:
+      if (current_unit->bytes_left == 0)
+	break;
+
+      length = current_unit->bytes_left;
+
+      p = salloc_w (current_unit->s, &length);
+      if (p == NULL)
+	goto io_error;
+
+      memset (p, ' ', current_unit->bytes_left);
+      if (sfree (current_unit->s) == FAILURE)
+	goto io_error;
+
+      break;
+
+    case UNFORMATTED_SEQUENTIAL:
+      m = current_unit->recl - current_unit->bytes_left; /* Bytes written */
+      c = file_position (current_unit->s);
+
+      length = sizeof (offset_t);
+
+      /* Write the length tail */
+
+      p = salloc_w (current_unit->s, &length);
+      if (p == NULL)
+	goto io_error;
+
+      *((offset_t *) p) = m;
+      if (sfree (current_unit->s) == FAILURE)
+	goto io_error;
+
+      /* Seek to the head and overwrite the bogus length with the real length */
+
+      p = salloc_w_at (current_unit->s, &length, c - m - length);
+      if (p == NULL)
+	generate_error (ERROR_OS, NULL);
+
+      *((offset_t *) p) = m;
+      if (sfree (current_unit->s) == FAILURE)
+	goto io_error;
+
+      /* Seek past the end of the current record */
+
+      if (sseek (current_unit->s, c + sizeof (offset_t)) == FAILURE)
+	goto io_error;
+
+      break;
+
+    case FORMATTED_SEQUENTIAL:
+      length = 1;
+      p = salloc_w (current_unit->s, &length);
+
+      if (!is_internal_unit())
+        {
+          if (p)
+            *p = '\n'; /* no CR for internal writes */
+          else
+            goto io_error;
+        }
+
+      if (sfree (current_unit->s) == FAILURE)
+ 	goto io_error;
+
+      break;
+
+    io_error:
+      generate_error (ERROR_OS, NULL);
+      break;
+    }
+}
+
+
+/* next_record()-- Position to the next record, which means moving to
+ * the end of the current record.  This can happen under several
+ * different conditions.  If the done flag is not set, we get ready to
+ * process the next record.  */
+
+void
+next_record (int done)
+{
+
+  current_unit->read_bad = 0;
+
+  if (g.mode == READING)
+    next_record_r (done);
+  else
+    next_record_w (done);
+
+  current_unit->current_record = 0;
+  if (current_unit->flags.access == ACCESS_DIRECT)
+    current_unit->last_record = file_position (current_unit->s) 
+                               / current_unit->recl;
+  else
+    current_unit->last_record++;
+
+  if (!done)
+    pre_position ();
+}
+
+
+/* Finalize the current data transfer.  For a nonadvancing transfer,
+ * this means advancing to the next record. */
+
+static void
+finalize_transfer (void)
+{
+
+  if (setjmp (g.eof_jump))
+    {
+       generate_error (ERROR_END, NULL);
+       return;
+    }
+
+  if ((ionml != NULL) && (ioparm.namelist_name != NULL))
+    {
+       if (ioparm.namelist_read_mode)
+         namelist_read();
+       else
+         namelist_write();
+    }
+
+  transfer = NULL;
+  if (current_unit == NULL)
+    return;
+
+  if (ioparm.list_format && g.mode == READING)
+    finish_list_read ();
+  else
+    {
+      free_fnodes ();
+
+      if (advance_status == ADVANCE_NO)
+	return;
+      next_record (1);
+      current_unit->current_record = 0;
+    }
+
+  sfree (current_unit->s);
+}
+
+
+/* The READ statement */
+
+void
+st_read (void)
+{
+
+  library_start ();
+
+  data_transfer_init (1);
+
+  /* Handle complications dealing with the endfile record.  It is
+   * significant that this is the only place where ERROR_END is
+   * generated.  Reading an end of file elsewhere is either end of
+   * record or an I/O error. */
+
+  if (current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (current_unit->endfile)
+      {
+      case NO_ENDFILE:
+	break;
+
+      case AT_ENDFILE:
+        if (!is_internal_unit())
+          {
+            generate_error (ERROR_END, NULL);
+            current_unit->endfile = AFTER_ENDFILE;
+          }
+	break;
+
+      case AFTER_ENDFILE:
+	generate_error (ERROR_ENDFILE, NULL);
+	break;
+      }
+}
+
+
+void
+st_read_done (void)
+{
+  finalize_transfer ();
+
+  library_end ();
+}
+
+
+void
+st_write (void)
+{
+
+  library_start ();
+  data_transfer_init (0);
+}
+
+
+void
+st_write_done (void)
+{
+
+  finalize_transfer ();
+
+  /* Deal with endfile conditions associated with sequential files */
+
+  if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
+    switch (current_unit->endfile)
+      {
+      case AT_ENDFILE:		/* Remain at the endfile record */
+	break;
+
+      case AFTER_ENDFILE:
+	current_unit->endfile = AT_ENDFILE;	/* Just at it now */
+	break;
+
+      case NO_ENDFILE:		/* Get rid of whatever is after this record */
+	if (struncate (current_unit->s) == FAILURE)
+	  generate_error (ERROR_OS, NULL);
+
+	current_unit->endfile = AT_ENDFILE;
+	break;
+      }
+
+  library_end ();
+}
+
+
+static void
+st_set_nml_var (void * var_addr, char * var_name, int var_name_len,
+                int kind, bt type)
+{
+  namelist_info *t1 = NULL, *t2 = NULL;
+  namelist_info *nml = (namelist_info *) get_mem (sizeof(
+                                                    namelist_info ));
+  nml->mem_pos = var_addr;
+  nml->var_name = (char*) get_mem (var_name_len+1);
+  strncpy (nml->var_name,var_name,var_name_len);
+  nml->var_name[var_name_len] = 0;
+  nml->len = kind;
+  nml->type = type;
+
+  nml->next = NULL;
+
+  if (ionml == NULL)
+     ionml = nml;
+  else
+    {
+      t1 = ionml;
+      while (t1 != NULL)
+       {
+         t2 = t1;
+         t1 = t1->next;
+       }
+       t2->next = nml;
+    }
+}
+
+void
+st_set_nml_var_int (void * var_addr, char * var_name, int var_name_len,
+                int kind)
+{
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_INTEGER);
+}
+
+void
+st_set_nml_var_float (void * var_addr, char * var_name, int var_name_len,
+                int kind)
+{
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_REAL);
+}
+
+void
+st_set_nml_var_char (void * var_addr, char * var_name, int var_name_len,
+                int kind)
+{
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_CHARACTER);
+}
+
+void
+st_set_nml_var_complex (void * var_addr, char * var_name, int var_name_len,
+                int kind)
+{
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_COMPLEX);
+}
+
+void
+st_set_nml_var_log (void * var_addr, char * var_name, int var_name_len,
+                int kind)
+{
+   st_set_nml_var (var_addr, var_name, var_name_len, kind, BT_LOGICAL);
+}
+
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
new file mode 100644
index 0000000..87f9095
--- /dev/null
+++ b/libgfortran/io/unit.c
@@ -0,0 +1,380 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <stdlib.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+/* Subroutines related to units */
+
+
+#define CACHE_SIZE 3
+static unit_t internal_unit, *unit_cache[CACHE_SIZE];
+
+
+/* This implementation is based on Stefan Nilsson's article in the
+ * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
+
+/* pseudo_random()-- Simple linear congruential pseudorandom number
+ * generator.  The period of this generator is 44071, which is plenty
+ * for our purposes.  */
+
+static int
+pseudo_random (void)
+{
+  static int x0 = 5341;
+
+  x0 = (22611 * x0 + 10) % 44071;
+  return x0;
+}
+
+
+/* rotate_left()-- Rotate the treap left */
+
+static unit_t *
+rotate_left (unit_t * t)
+{
+  unit_t *temp;
+
+  temp = t->right;
+  t->right = t->right->left;
+  temp->left = t;
+
+  return temp;
+}
+
+
+/* rotate_right()-- Rotate the treap right */
+
+static unit_t *
+rotate_right (unit_t * t)
+{
+  unit_t *temp;
+
+  temp = t->left;
+  t->left = t->left->right;
+  temp->right = t;
+
+  return temp;
+}
+
+
+
+static int
+compare (int a, int b)
+{
+
+  if (a < b)
+    return -1;
+  if (a > b)
+    return 1;
+
+  return 0;
+}
+
+
+/* insert()-- Recursive insertion function.  Returns the updated treap. */
+
+static unit_t *
+insert (unit_t * new, unit_t * t)
+{
+  int c;
+
+  if (t == NULL)
+    return new;
+
+  c = compare (new->unit_number, t->unit_number);
+
+  if (c < 0)
+    {
+      t->left = insert (new, t->left);
+      if (t->priority < t->left->priority)
+	t = rotate_right (t);
+    }
+
+  if (c > 0)
+    {
+      t->right = insert (new, t->right);
+      if (t->priority < t->right->priority)
+	t = rotate_left (t);
+    }
+
+  if (c == 0)
+    internal_error ("insert(): Duplicate key found!");
+
+  return t;
+}
+
+
+/* insert_unit()-- Given a new node, insert it into the treap.  It is
+ * an error to insert a key that already exists. */
+
+void
+insert_unit (unit_t * new)
+{
+
+  new->priority = pseudo_random ();
+  g.unit_root = insert (new, g.unit_root);
+}
+
+
+static unit_t *
+delete_root (unit_t * t)
+{
+  unit_t *temp;
+
+  if (t->left == NULL)
+    return t->right;
+  if (t->right == NULL)
+    return t->left;
+
+  if (t->left->priority > t->right->priority)
+    {
+      temp = rotate_right (t);
+      temp->right = delete_root (t);
+    }
+  else
+    {
+      temp = rotate_left (t);
+      temp->left = delete_root (t);
+    }
+
+  return temp;
+}
+
+
+/* delete_treap()-- Delete an element from a tree.  The 'old' value
+ * does not necessarily have to point to the element to be deleted, it
+ * must just point to a treap structure with the key to be deleted.
+ * Returns the new root node of the tree. */
+
+static unit_t *
+delete_treap (unit_t * old, unit_t * t)
+{
+  int c;
+
+  if (t == NULL)
+    return NULL;
+
+  c = compare (old->unit_number, t->unit_number);
+
+  if (c < 0)
+    t->left = delete_treap (old, t->left);
+  if (c > 0)
+    t->right = delete_treap (old, t->right);
+  if (c == 0)
+    t = delete_root (t);
+
+  return t;
+}
+
+
+/* delete_unit()-- Delete a unit from a tree */
+
+static void
+delete_unit (unit_t * old)
+{
+
+  g.unit_root = delete_treap (old, g.unit_root);
+}
+
+
+/* find_unit()-- Given an integer, return a pointer to the unit
+ * structure.  Returns NULL if the unit does not exist. */
+
+unit_t *
+find_unit (int n)
+{
+  unit_t *p;
+  int c;
+
+  for (c = 0; c < CACHE_SIZE; c++)
+    if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
+      {
+	p = unit_cache[c];
+	return p;
+      }
+
+  p = g.unit_root;
+  while (p != NULL)
+    {
+      c = compare (n, p->unit_number);
+      if (c < 0)
+	p = p->left;
+      if (c > 0)
+	p = p->right;
+      if (c == 0)
+	break;
+    }
+
+  if (p != NULL)
+    {
+      for (c = 0; c < CACHE_SIZE - 1; c++)
+	unit_cache[c] = unit_cache[c + 1];
+
+      unit_cache[CACHE_SIZE - 1] = p;
+    }
+
+  return p;
+}
+
+/* get_unit()-- Returns the unit structure associated with the integer
+ * unit or the internal file. */
+
+unit_t *
+get_unit (int read_flag)
+{
+  unit_t *u;
+
+  if (ioparm.internal_unit != NULL)
+    {
+      internal_unit.s =
+	open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
+
+      /* Set flags for the internal unit */
+
+      internal_unit.flags.access = ACCESS_SEQUENTIAL;
+      internal_unit.flags.action = ACTION_READWRITE;
+      internal_unit.flags.form = FORM_FORMATTED;
+      internal_unit.flags.delim = DELIM_NONE;
+
+      return &internal_unit;
+    }
+
+  /* Has to be an external unit */
+
+  u = find_unit (ioparm.unit);
+  if (u != NULL)
+    return u;
+
+  return NULL;
+}
+
+
+/* is_internal_unit()-- Determine if the current unit is internal or
+ * not */
+
+int
+is_internal_unit ()
+{
+
+  return current_unit == &internal_unit;
+}
+
+
+
+/*************************/
+/* Initialize everything */
+
+void
+init_units (void)
+{
+  offset_t m, n;
+  unit_t *u;
+  int i;
+
+  if (options.stdin_unit >= 0)
+    {				/* STDIN */
+      u = get_mem (sizeof (unit_t));
+
+      u->unit_number = options.stdin_unit;
+      u->s = input_stream ();
+
+      u->flags.action = ACTION_READ;
+
+      u->flags.access = ACCESS_SEQUENTIAL;
+      u->flags.form = FORM_FORMATTED;
+      u->flags.status = STATUS_OLD;
+      u->flags.blank = BLANK_ZERO;
+      u->flags.position = POSITION_ASIS;
+
+      u->recl = options.default_recl;
+      u->endfile = NO_ENDFILE;
+
+      insert_unit (u);
+    }
+
+  if (options.stdout_unit >= 0)
+    {				/* STDOUT */
+      u = get_mem (sizeof (unit_t));
+
+      u->unit_number = options.stdout_unit;
+      u->s = output_stream ();
+
+      u->flags.action = ACTION_WRITE;
+
+      u->flags.access = ACCESS_SEQUENTIAL;
+      u->flags.form = FORM_FORMATTED;
+      u->flags.status = STATUS_OLD;
+      u->flags.blank = BLANK_ZERO;
+      u->flags.position = POSITION_ASIS;
+
+      u->recl = options.default_recl;
+      u->endfile = AT_ENDFILE;
+
+      insert_unit (u);
+    }
+
+  /* Calculate the maximum file offset in a portable manner.
+   * max will be the largest signed number for the type offset_t.
+   *
+   * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
+
+  g.max_offset = 0;
+  for (i=0; i < sizeof(g.max_offset) * 8 - 1; i++)
+    g.max_offset = g.max_offset + ((offset_t) 1 << i);
+
+}
+
+
+/* close_unit()-- Close a unit.  The stream is closed, and any memory
+ * associated with the stream is freed.  Returns nonzero on I/O error. */
+
+int
+close_unit (unit_t * u)
+{
+  int i, rc;
+
+  for (i = 0; i < CACHE_SIZE; i++)
+    if (unit_cache[i] == u)
+      unit_cache[i] = NULL;
+
+  rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+
+  delete_unit (u);
+  free_mem (u);
+
+  return rc;
+}
+
+
+/* close_units()-- Delete units on completion.  We just keep deleting
+ * the root of the treap until there is nothing left. */
+
+void
+close_units (void)
+{
+
+  while (g.unit_root != NULL)
+    close_unit (g.unit_root);
+}
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
new file mode 100644
index 0000000..185608a
--- /dev/null
+++ b/libgfortran/io/unix.c
@@ -0,0 +1,1432 @@
+/* Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Unix stream I/O module */
+
+#include "config.h"
+#include <stdlib.h>
+#include <limits.h>
+
+#include <unistd.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+
+#include "libgfortran.h"
+#include "io.h"
+
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#ifndef MAP_FAILED
+#define MAP_FAILED ((void *) -1)
+#endif
+
+/* This implementation of stream I/O is based on the paper:
+ *
+ *  "Exploiting the advantages of mapped files for stream I/O",
+ *  O. Krieger, M. Stumm and R. Umrau, "Proceedings of the 1992 Winter
+ *  USENIX conference", p. 27-42.
+ *
+ * It differs in a number of ways from the version described in the
+ * paper.  First of all, threads are not an issue during I/O and we
+ * also don't have to worry about having multiple regions, since
+ * fortran's I/O model only allows you to be one place at a time.
+ *
+ * On the other hand, we have to be able to writing at the end of a
+ * stream, read from the start of a stream or read and write blocks of
+ * bytes from an arbitrary position.  After opening a file, a pointer
+ * to a stream structure is returned, which is used to handle file
+ * accesses until the file is closed.
+ *
+ * salloc_at_r(stream, len, where)-- Given a stream pointer, return a
+ * pointer to a block of memory that mirror the file at position
+ * 'where' that is 'len' bytes long.  The len integer is updated to
+ * reflect how many bytes were actually read.  The only reason for a
+ * short read is end of file.  The file pointer is updated.  The
+ * pointer is valid until the next call to salloc_*.
+ *
+ * salloc_at_w(stream, len, where)-- Given the stream pointer, returns
+ * a pointer to a block of memory that is updated to reflect the state
+ * of the file.  The length of the buffer is always equal to that
+ * requested.  The buffer must be completely set by the caller.  When
+ * data has been written, the sfree() function must be called to
+ * indicate that the caller is done writing data to the buffer.  This
+ * may or may not cause a physical write.
+ *
+ * Short forms of these are salloc_r() and salloc_w() which drop the
+ * 'where' parameter and use the current file pointer. */
+
+
+#define BUFFER_SIZE 8192
+
+typedef struct
+{
+  stream st;
+
+  int fd;
+  offset_t buffer_offset;	/* File offset of the start of the buffer */
+  offset_t physical_offset;	/* Current physical file offset */
+  offset_t logical_offset;	/* Current logical file offset */
+  offset_t dirty_offset;	/* Start of modified bytes in buffer */
+  offset_t file_length;		/* Length of the file, -1 if not seekable. */
+
+  char *buffer;
+  int len;			/* Physical length of the current buffer */
+  int active;			/* Length of valid bytes in the buffer */
+
+  int prot;
+  int ndirty;			/* Dirty bytes starting at dirty_offset */
+
+  unsigned unbuffered:1, mmaped:1;
+
+  char small_buffer[BUFFER_SIZE];
+
+}
+unix_stream;
+
+/*move_pos_offset()--  Move the record pointer right or left
+ *relative to current position */
+
+int
+move_pos_offset (stream* st, int pos_off)
+{
+  unix_stream * str = (unix_stream*)st;
+  if (pos_off < 0)
+    {
+      str->active  += pos_off;
+      if (str->active < 0)
+         str->active = 0;
+
+      str->logical_offset  += pos_off;
+
+      if (str->dirty_offset+str->ndirty > str->logical_offset)
+        {
+          if (str->ndirty +  pos_off > 0)
+            str->ndirty += pos_off ;
+          else
+            {
+              str->dirty_offset +=  pos_off + pos_off;
+              str->ndirty = 0 ;
+            }
+        }
+
+    return pos_off ;
+  }
+  return 0 ;
+}
+
+
+/* fix_fd()-- Given a file descriptor, make sure it is not one of the
+ * standard descriptors, returning a non-standard descriptor.  If the
+ * user specifies that system errors should go to standard output,
+ * then closes standard output, we don't want the system errors to a
+ * file that has been given file descriptor 1 or 0.  We want to send
+ * the error to the invalid descriptor. */
+
+static int
+fix_fd (int fd)
+{
+  int input, output, error;
+
+  input = output = error = 0;
+
+/* Unix allocates the lowest descriptors first, so a loop is not
+ * required, but this order is. */
+
+  if (fd == STDIN_FILENO)
+    {
+      fd = dup (fd);
+      input = 1;
+    }
+  if (fd == STDOUT_FILENO)
+    {
+      fd = dup (fd);
+      output = 1;
+    }
+  if (fd == STDERR_FILENO)
+    {
+      fd = dup (fd);
+      error = 1;
+    }
+
+  if (input)
+    close (STDIN_FILENO);
+  if (output)
+    close (STDOUT_FILENO);
+  if (error)
+    close (STDERR_FILENO);
+
+  return fd;
+}
+
+
+/* write()-- Write a buffer to a descriptor, allowing for short writes */
+
+static int
+writen (int fd, char *buffer, int len)
+{
+  int n, n0;
+
+  n0 = len;
+
+  while (len > 0)
+    {
+      n = write (fd, buffer, len);
+      if (n < 0)
+	return n;
+
+      buffer += n;
+      len -= n;
+    }
+
+  return n0;
+}
+
+
+#if 0
+/* readn()-- Read bytes into a buffer, allowing for short reads.  If
+ * fewer than len bytes are returned, it is because we've hit the end
+ * of file. */
+
+static int
+readn (int fd, char *buffer, int len)
+{
+  int nread, n;
+
+  nread = 0;
+
+  while (len > 0)
+    {
+      n = read (fd, buffer, len);
+      if (n < 0)
+	return n;
+
+      if (n == 0)
+	return nread;
+
+      buffer += n;
+      nread += n;
+      len -= n;
+    }
+
+  return nread;
+}
+#endif
+
+
+/* get_oserror()-- Get the most recent operating system error.  For
+ * unix, this is errno. */
+
+const char *
+get_oserror (void)
+{
+
+  return strerror (errno);
+}
+
+
+/* sys_exit()-- Terminate the program with an exit code */
+
+void
+sys_exit (int code)
+{
+
+  exit (code);
+}
+
+
+
+/*********************************************************************
+    File descriptor stream functions
+*********************************************************************/
+
+/* fd_flush()-- Write bytes that need to be written */
+
+static try
+fd_flush (unix_stream * s)
+{
+
+  if (s->ndirty == 0)
+    return SUCCESS;;
+
+  if (s->physical_offset != s->dirty_offset &&
+      lseek (s->fd, s->dirty_offset, SEEK_SET) < 0)
+    return FAILURE;
+
+  if (writen (s->fd, s->buffer + (s->dirty_offset - s->buffer_offset),
+	      s->ndirty) < 0)
+    return FAILURE;
+
+  s->physical_offset = s->dirty_offset + s->ndirty;
+  if (s->physical_offset > s->file_length)
+    s->file_length = s->physical_offset;
+  s->ndirty = 0;
+
+  return SUCCESS;
+}
+
+
+/* fd_alloc()-- Arrange a buffer such that the salloc() request can be
+ * satisfied.  This subroutine gets the buffer ready for whatever is
+ * to come next. */
+
+static void
+fd_alloc (unix_stream * s, offset_t where, int *len)
+{
+  char *new_buffer;
+  int n, read_len;
+
+  if (*len <= BUFFER_SIZE)
+    {
+      new_buffer = s->small_buffer;
+      read_len = BUFFER_SIZE;
+    }
+  else
+    {
+      new_buffer = get_mem (*len);
+      read_len = *len;
+    }
+
+  /* Salvage bytes currently within the buffer.  This is important for
+   * devices that cannot seek. */
+
+  if (s->buffer != NULL && s->buffer_offset <= where &&
+      where <= s->buffer_offset + s->active)
+    {
+
+      n = s->active - (where - s->buffer_offset);
+      memmove (new_buffer, s->buffer + (where - s->buffer_offset), n);
+
+      s->active = n;
+    }
+  else
+    {				/* new buffer starts off empty */
+      s->active = 0;
+    }
+
+  s->buffer_offset = where;
+
+  /* free the old buffer if necessary */
+
+  if (s->buffer != NULL && s->buffer != s->small_buffer)
+    free_mem (s->buffer);
+
+  s->buffer = new_buffer;
+  s->len = read_len;
+  s->mmaped = 0;
+}
+
+
+/* fd_alloc_r_at()-- Allocate a stream buffer for reading.  Either
+ * we've already buffered the data or we need to load it.  Returns
+ * NULL on I/O error. */
+
+static char *
+fd_alloc_r_at (unix_stream * s, int *len, offset_t where)
+{
+  offset_t m;
+  int n;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (s->buffer != NULL && s->buffer_offset <= where &&
+      where + *len <= s->buffer_offset + s->active)
+    {
+
+      /* Return a position within the current buffer */
+
+      s->logical_offset = where + *len;
+      return s->buffer + where - s->buffer_offset;
+    }
+
+  fd_alloc (s, where, len);
+
+  m = where + s->active;
+
+  if (s->physical_offset != m && lseek (s->fd, m, SEEK_SET) < 0)
+    return NULL;
+
+  n = read (s->fd, s->buffer + s->active, s->len - s->active);
+  if (n < 0)
+    return NULL;
+
+  s->physical_offset = where + n;
+
+  s->active += n;
+  if (s->active < *len)
+    *len = s->active;		/* Bytes actually available */
+
+  s->logical_offset = where + *len;
+
+  return s->buffer;
+}
+
+
+/* fd_alloc_w_at()-- Allocate a stream buffer for writing.  Either
+ * we've already buffered the data or we need to load it. */
+
+static char *
+fd_alloc_w_at (unix_stream * s, int *len, offset_t where)
+{
+  offset_t n;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (s->buffer == NULL || s->buffer_offset > where ||
+      where + *len > s->buffer_offset + s->len)
+    {
+
+      if (fd_flush (s) == FAILURE)
+	return NULL;
+      fd_alloc (s, where, len);
+    }
+
+  /* Return a position within the current buffer */
+
+  if (s->ndirty == 0)
+    {				/* First write into a clean buffer */
+      s->dirty_offset = where;
+      s->ndirty = *len;
+    }
+  else
+    {
+      if (s->dirty_offset + s->ndirty == where)
+	s->ndirty += *len;
+      else
+	fd_flush (s);		/* Can't combine two dirty blocks */
+    }
+
+  s->logical_offset = where + *len;
+
+  n = s->logical_offset - s->buffer_offset;
+  if (n > s->active)
+    s->active = n;
+
+  return s->buffer + where - s->buffer_offset;
+}
+
+
+static try
+fd_sfree (unix_stream * s)
+{
+
+  if (s->ndirty != 0 &&
+      (s->buffer != s->small_buffer || options.all_unbuffered ||
+       s->unbuffered))
+    return fd_flush (s);
+
+  return SUCCESS;
+}
+
+
+static int
+fd_seek (unix_stream * s, offset_t offset)
+{
+
+  s->physical_offset = s->logical_offset = offset;
+
+  return (lseek (s->fd, offset, SEEK_SET) < 0) ? FAILURE : SUCCESS;
+}
+
+
+/* truncate_file()-- Given a unit, truncate the file at the current
+ * position.  Sets the physical location to the new end of the file.
+ * Returns nonzero on error. */
+
+static try
+fd_truncate (unix_stream * s)
+{
+
+  if (ftruncate (s->fd, s->logical_offset))
+    return FAILURE;
+
+  s->physical_offset = s->file_length = s->logical_offset;
+
+  if (lseek (s->fd, s->file_length, SEEK_SET) == -1)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+static try
+fd_close (unix_stream * s)
+{
+
+  if (fd_flush (s) == FAILURE)
+    return FAILURE;
+
+  if (s->buffer != NULL && s->buffer != s->small_buffer)
+    free_mem (s->buffer);
+
+  if (close (s->fd) < 0)
+    return FAILURE;
+
+  free_mem (s);
+
+  return SUCCESS;
+}
+
+
+static void
+fd_open (unix_stream * s)
+{
+
+  if (isatty (s->fd))
+    s->unbuffered = 1;
+
+  s->st.alloc_r_at = (void *) fd_alloc_r_at;
+  s->st.alloc_w_at = (void *) fd_alloc_w_at;
+  s->st.sfree = (void *) fd_sfree;
+  s->st.close = (void *) fd_close;
+  s->st.seek = (void *) fd_seek;
+  s->st.truncate = (void *) fd_truncate;
+
+  s->buffer = NULL;
+}
+
+
+/*********************************************************************
+    mmap stream functions
+
+ Because mmap() is not capable of extending a file, we have to keep
+ track of how long the file is.  We also have to be able to detect end
+ of file conditions.  If there are multiple writers to the file (which
+ can only happen outside the current program), things will get
+ confused.  Then again, things will get confused anyway.
+
+*********************************************************************/
+
+#if HAVE_MMAP
+
+static int page_size, page_mask;
+
+/* mmap_flush()-- Deletes a memory mapping if something is mapped. */
+
+static try
+mmap_flush (unix_stream * s)
+{
+
+  if (!s->mmaped)
+    return fd_flush (s);
+
+  if (s->buffer == NULL)
+    return SUCCESS;
+
+  if (munmap (s->buffer, s->active))
+    return FAILURE;
+
+  s->buffer = NULL;
+  s->active = 0;
+
+  return SUCCESS;
+}
+
+
+/* mmap_alloc()-- mmap() a section of the file.  The whole section is
+ * guaranteed to be mappable. */
+
+static try
+mmap_alloc (unix_stream * s, offset_t where, int *len)
+{
+  offset_t offset;
+  int length;
+  char *p;
+
+  if (mmap_flush (s) == FAILURE)
+    return FAILURE;
+
+  offset = where & page_mask;	/* Round down to the next page */
+
+  length = ((where - offset) & page_mask) + 2 * page_size;
+
+  p = mmap (NULL, length, s->prot, MAP_SHARED, s->fd, offset);
+  if (p == (char *) MAP_FAILED)
+    return FAILURE;
+
+  s->mmaped = 1;
+  s->buffer = p;
+  s->buffer_offset = offset;
+  s->active = length;
+
+  return SUCCESS;
+}
+
+
+static char *
+mmap_alloc_r_at (unix_stream * s, int *len, offset_t where)
+{
+  offset_t m;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  m = where + *len;
+
+  if ((s->buffer == NULL || s->buffer_offset > where ||
+       m > s->buffer_offset + s->active) &&
+      mmap_alloc (s, where, len) == FAILURE)
+    return NULL;
+
+  if (m > s->file_length)
+    {
+      *len = s->file_length - s->logical_offset;
+      s->logical_offset = s->file_length;
+    }
+  else
+    s->logical_offset = m;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+static char *
+mmap_alloc_w_at (unix_stream * s, int *len, offset_t where)
+{
+  if (where == -1)
+    where = s->logical_offset;
+
+  /* If we're extending the file, we have to use file descriptor
+   * methods. */
+
+  if (where + *len > s->file_length)
+    {
+      if (s->mmaped)
+	mmap_flush (s);
+      return fd_alloc_w_at (s, len, where);
+    }
+
+  if ((s->buffer == NULL || s->buffer_offset > where ||
+       where + *len > s->buffer_offset + s->active) &&
+      mmap_alloc (s, where, len) == FAILURE)
+    return NULL;
+
+  s->logical_offset = where + *len;
+
+  return s->buffer + where - s->buffer_offset;
+}
+
+
+static int
+mmap_seek (unix_stream * s, offset_t offset)
+{
+
+  s->logical_offset = offset;
+  return SUCCESS;
+}
+
+
+static try
+mmap_close (unix_stream * s)
+{
+  try t;
+
+  t = mmap_flush (s);
+
+  if (close (s->fd) < 0)
+    t = FAILURE;
+  free_mem (s);
+
+  return t;
+}
+
+
+static try
+mmap_sfree (unix_stream * s)
+{
+
+  return SUCCESS;
+}
+
+
+/* mmap_open()-- mmap_specific open.  If the particular file cannot be
+ * mmap()-ed, we fall back to the file descriptor functions. */
+
+static try
+mmap_open (unix_stream * s)
+{
+  char *p;
+  int i;
+
+  page_size = getpagesize ();
+  page_mask = ~0;
+
+  p = mmap (0, page_size, s->prot, MAP_SHARED, s->fd, 0);
+  if (p == (char *) MAP_FAILED)
+    {
+      fd_open (s);
+      return SUCCESS;
+    }
+
+  munmap (p, page_size);
+
+  i = page_size >> 1;
+  while (i != 0)
+    {
+      page_mask <<= 1;
+      i >>= 1;
+    }
+
+  s->st.alloc_r_at = (void *) mmap_alloc_r_at;
+  s->st.alloc_w_at = (void *) mmap_alloc_w_at;
+  s->st.sfree = (void *) mmap_sfree;
+  s->st.close = (void *) mmap_close;
+  s->st.seek = (void *) mmap_seek;
+  s->st.truncate = (void *) fd_truncate;
+
+  if (lseek (s->fd, s->file_length, SEEK_SET) < 0)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+#endif
+
+
+/*********************************************************************
+  memory stream functions - These are used for internal files
+
+  The idea here is that a single stream structure is created and all
+  requests must be satisfied from it.  The location and size of the
+  buffer is the character variable supplied to the READ or WRITE
+  statement.
+
+*********************************************************************/
+
+
+static char *
+mem_alloc_r_at (unix_stream * s, int *len, offset_t where)
+{
+  offset_t n;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  if (where < s->buffer_offset || where > s->buffer_offset + s->active)
+    return NULL;
+
+  if (is_internal_unit() && where + *len > s->file_length)
+    return NULL;
+
+  s->logical_offset = where + *len;
+
+  n = (where - s->buffer_offset) - s->active;
+  if (*len > n)
+    *len = n;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+static char *
+mem_alloc_w_at (unix_stream * s, int *len, offset_t where)
+{
+  offset_t m;
+
+  if (where == -1)
+    where = s->logical_offset;
+
+  m = where + *len;
+
+  if (where < s->buffer_offset || m > s->buffer_offset + s->active)
+    return NULL;
+
+  s->logical_offset = m;
+
+  return s->buffer + (where - s->buffer_offset);
+}
+
+
+static int
+mem_seek (unix_stream * s, offset_t offset)
+{
+
+  if (offset > s->file_length)
+    {
+      errno = ESPIPE;
+      return FAILURE;
+    }
+
+  s->logical_offset = offset;
+  return SUCCESS;
+}
+
+
+static int
+mem_truncate (unix_stream * s)
+{
+
+  return SUCCESS;
+}
+
+
+static try
+mem_close (unix_stream * s)
+{
+
+  return SUCCESS;
+}
+
+
+static try
+mem_sfree (unix_stream * s)
+{
+
+  return SUCCESS;
+}
+
+
+
+/*********************************************************************
+  Public functions -- A reimplementation of this module needs to
+  define functional equivalents of the following.
+*********************************************************************/
+
+/* empty_internal_buffer()-- Zero the buffer of Internal file */
+
+void
+empty_internal_buffer(stream *strm)
+{
+   unix_stream * s = (unix_stream *) strm;
+   memset(s->buffer, ' ', s->file_length);
+}
+
+/* open_internal()-- Returns a stream structure from an internal file */
+
+stream *
+open_internal (char *base, int length)
+{
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+
+  s->buffer = base;
+  s->buffer_offset = 0;
+
+  s->logical_offset = 0;
+  s->active = s->file_length = length;
+
+  s->st.alloc_r_at = (void *) mem_alloc_r_at;
+  s->st.alloc_w_at = (void *) mem_alloc_w_at;
+  s->st.sfree = (void *) mem_sfree;
+  s->st.close = (void *) mem_close;
+  s->st.seek = (void *) mem_seek;
+  s->st.truncate = (void *) mem_truncate;
+
+  return (stream *) s;
+}
+
+
+/* fd_to_stream()-- Given an open file descriptor, build a stream
+ * around it. */
+
+static stream *
+fd_to_stream (int fd, int prot)
+{
+  struct stat statbuf;
+  unix_stream *s;
+
+  s = get_mem (sizeof (unix_stream));
+
+  s->fd = fd;
+  s->buffer_offset = 0;
+  s->physical_offset = 0;
+  s->logical_offset = 0;
+  s->prot = prot;
+
+  /* Get the current length of the file. */
+
+  fstat (fd, &statbuf);
+  s->file_length = S_ISREG (statbuf.st_mode) ? statbuf.st_size : -1;
+
+#if HAVE_MMAP
+  mmap_open (s);
+#else
+  fd_open (s);
+#endif
+
+  return (stream *) s;
+}
+
+
+/* unpack_filename()-- Given a fortran string and a pointer to a
+ * buffer that is PATH_MAX characters, convert the fortran string to a
+ * C string in the buffer.  Returns nonzero if this is not possible.  */
+
+static int
+unpack_filename (char *cstring, const char *fstring, int len)
+{
+
+  len = fstrlen (fstring, len);
+  if (len >= PATH_MAX)
+    return 1;
+
+  memmove (cstring, fstring, len);
+  cstring[len] = '\0';
+
+  return 0;
+}
+
+
+/* tempfile()-- Generate a temporary filename for a scratch file and
+ * open it.  mkstemp() opens the file for reading and writing, but the
+ * library mode prevents anything that is not allowed.  The descriptor
+ * is returns, which is less than zero on error.  The template is
+ * pointed to by ioparm.file, which is copied into the unit structure
+ * and freed later. */
+
+static int
+tempfile (void)
+{
+  const char *tempdir;
+  char *template;
+  int fd;
+
+  tempdir = getenv ("GFORTRAN_TMPDIR");
+  if (tempdir == NULL)
+    tempdir = getenv ("TMP");
+  if (tempdir == NULL)
+    tempdir = DEFAULT_TEMPDIR;
+
+  template = get_mem (strlen (tempdir) + 20);
+
+  st_sprintf (template, "%s/gfortantmpXXXXXX", tempdir);
+
+  fd = mkstemp (template);
+
+  if (fd < 0)
+    free_mem (template);
+  else
+    {
+      ioparm.file = template;
+      ioparm.file_len = strlen (template);	/* Don't include trailing nul */
+    }
+
+  return fd;
+}
+
+
+/* regular_file()-- Open a regular file.  Returns the descriptor, which is less than zero on error. */
+
+static int
+regular_file (unit_action action, unit_status status)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+  int mode;
+
+  if (unpack_filename (path, ioparm.file, ioparm.file_len))
+    {
+      errno = ENOENT;		/* Fake an OS error */
+      return -1;
+    }
+
+  mode = 0;
+
+  switch (action)
+    {
+    case ACTION_READ:
+      mode = O_RDONLY;
+      break;
+
+    case ACTION_WRITE:
+      mode = O_WRONLY;
+      break;
+
+    case ACTION_READWRITE:
+      mode = O_RDWR;
+      break;
+
+    default:
+      internal_error ("regular_file(): Bad action");
+    }
+
+  switch (status)
+    {
+    case STATUS_NEW:
+      mode |= O_CREAT | O_EXCL;
+      break;
+
+    case STATUS_OLD:		/* file must exist, so check for its existence */
+      if (stat (path, &statbuf) < 0)
+	return -1;
+      break;
+
+    case STATUS_UNKNOWN:
+    case STATUS_SCRATCH:
+      mode |= O_CREAT;
+      break;
+
+    case STATUS_REPLACE:
+      mode |= O_TRUNC;
+      break;
+
+    default:
+      internal_error ("regular_file(): Bad status");
+    }
+
+  // mode |= O_LARGEFILE;
+
+  return open (path, mode,
+	       S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH);
+}
+
+
+/* open_external()-- Open an external file, unix specific version.
+ * Returns NULL on operating system error. */
+
+stream *
+open_external (unit_action action, unit_status status)
+{
+  int fd, prot;
+
+  fd =
+    (status == STATUS_SCRATCH) ? tempfile () : regular_file (action, status);
+
+  if (fd < 0)
+    return NULL;
+  fd = fix_fd (fd);
+
+  switch (action)
+    {
+    case ACTION_READ:
+      prot = PROT_READ;
+      break;
+
+    case ACTION_WRITE:
+      prot = PROT_WRITE;
+      break;
+
+    case ACTION_READWRITE:
+      prot = PROT_READ | PROT_WRITE;
+      break;
+
+    default:
+      internal_error ("open_external(): Bad action");
+    }
+
+  /* If this is a scratch file, we can unlink it now and the file will
+   * go away when it is closed. */
+
+  if (status == STATUS_SCRATCH)
+    unlink (ioparm.file);
+
+  return fd_to_stream (fd, prot);
+}
+
+
+/* input_stream()-- Return a stream pointer to the default input stream.
+ * Called on initialization. */
+
+stream *
+input_stream (void)
+{
+
+  return fd_to_stream (STDIN_FILENO, PROT_READ);
+}
+
+
+/* output_stream()-- Return a stream pointer to the default input stream.
+ * Called on initialization. */
+
+stream *
+output_stream (void)
+{
+
+  return fd_to_stream (STDOUT_FILENO, PROT_WRITE);
+}
+
+
+/* init_error_stream()-- Return a pointer to the error stream.  This
+ * subroutine is called when the stream is needed, rather than at
+ * initialization.  We want to work even if memory has been seriously
+ * corrupted. */
+
+stream *
+init_error_stream (void)
+{
+  static unix_stream error;
+
+  memset (&error, '\0', sizeof (error));
+
+  error.fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
+
+  error.st.alloc_w_at = (void *) fd_alloc_w_at;
+  error.st.sfree = (void *) fd_sfree;
+
+  error.unbuffered = 1;
+  error.buffer = error.small_buffer;
+
+  return (stream *) & error;
+}
+
+
+/* compare_file_filename()-- Given an open stream and a fortran string
+ * that is a filename, figure out if the file is the same as the
+ * filename. */
+
+int
+compare_file_filename (stream * s, const char *name, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat st1, st2;
+
+  if (unpack_filename (path, name, len))
+    return 0;			/* Can't be the same */
+
+  /* If the filename doesn't exist, then there is no match with the
+   * existing file. */
+
+  if (stat (path, &st1) < 0)
+    return 0;
+
+  fstat (((unix_stream *) s)->fd, &st2);
+
+  return (st1.st_dev == st2.st_dev) && (st1.st_ino == st2.st_ino);
+}
+
+
+/* find_file0()-- Recursive work function for find_file() */
+
+static unit_t *
+find_file0 (unit_t * u, struct stat *st1)
+{
+  struct stat st2;
+  unit_t *v;
+
+  if (u == NULL)
+    return NULL;
+
+  if (fstat (((unix_stream *) u->s)->fd, &st2) >= 0 &&
+      st1->st_dev == st2.st_dev && st1->st_ino == st2.st_ino)
+    return u;
+
+  v = find_file0 (u->left, st1);
+  if (v != NULL)
+    return v;
+
+  v = find_file0 (u->right, st1);
+  if (v != NULL)
+    return v;
+
+  return NULL;
+}
+
+
+/* find_file()-- Take the current filename and see if there is a unit
+ * that has the file already open.  Returns a pointer to the unit if so. */
+
+unit_t *
+find_file (void)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (unpack_filename (path, ioparm.file, ioparm.file_len))
+    return NULL;
+
+  if (stat (path, &statbuf) < 0)
+    return NULL;
+
+  return find_file0 (g.unit_root, &statbuf);
+}
+
+
+/* stream_at_bof()-- Returns nonzero if the stream is at the beginning
+ * of the file. */
+
+int
+stream_at_bof (stream * s)
+{
+  unix_stream *us;
+
+  us = (unix_stream *) s;
+
+  if (!us->mmaped)
+    return 0;			/* File is not seekable */
+
+  return us->logical_offset == 0;
+}
+
+
+/* stream_at_eof()-- Returns nonzero if the stream is at the beginning
+ * of the file. */
+
+int
+stream_at_eof (stream * s)
+{
+  unix_stream *us;
+
+  us = (unix_stream *) s;
+
+  if (!us->mmaped)
+    return 0;			/* File is not seekable */
+
+  return us->logical_offset == us->dirty_offset;
+}
+
+
+/* delete_file()-- Given a unit structure, delete the file associated
+ * with the unit.  Returns nonzero if something went wrong. */
+
+int
+delete_file (unit_t * u)
+{
+  char path[PATH_MAX + 1];
+
+  if (unpack_filename (path, u->file, u->file_len))
+    {				/* Shouldn't be possible */
+      errno = ENOENT;
+      return 1;
+    }
+
+  return unlink (path);
+}
+
+
+/* file_exists()-- Returns nonzero if the current filename exists on
+ * the system */
+
+int
+file_exists (void)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (unpack_filename (path, ioparm.file, ioparm.file_len))
+    return 0;
+
+  if (stat (path, &statbuf) < 0)
+    return 0;
+
+  return 1;
+}
+
+
+
+static const char *yes = "YES", *no = "NO", *unknown = "UNKNOWN";
+
+/* inquire_sequential()-- Given a fortran string, determine if the
+ * file is suitable for sequential access.  Returns a C-style
+ * string. */
+
+const char *
+inquire_sequential (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_direct()-- Given a fortran string, determine if the file is
+ * suitable for direct access.  Returns a C-style string. */
+
+const char *
+inquire_direct (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_formatted()-- Given a fortran string, determine if the file
+ * is suitable for formatted form.  Returns a C-style string. */
+
+const char *
+inquire_formatted (const char *string, int len)
+{
+  char path[PATH_MAX + 1];
+  struct stat statbuf;
+
+  if (string == NULL ||
+      unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
+    return unknown;
+
+  if (S_ISREG (statbuf.st_mode) ||
+      S_ISBLK (statbuf.st_mode) ||
+      S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
+    return yes;
+
+  if (S_ISDIR (statbuf.st_mode))
+    return no;
+
+  return unknown;
+}
+
+
+/* inquire_unformatted()-- Given a fortran string, determine if the file
+ * is suitable for unformatted form.  Returns a C-style string. */
+
+const char *
+inquire_unformatted (const char *string, int len)
+{
+
+  return inquire_formatted (string, len);
+}
+
+
+/* inquire_access()-- Given a fortran string, determine if the file is
+ * suitable for access. */
+
+static const char *
+inquire_access (const char *string, int len, int mode)
+{
+  char path[PATH_MAX + 1];
+
+  if (string == NULL || unpack_filename (path, string, len) ||
+      access (path, mode) < 0)
+    return no;
+
+  return yes;
+}
+
+
+/* inquire_read()-- Given a fortran string, determine if the file is
+ * suitable for READ access. */
+
+const char *
+inquire_read (const char *string, int len)
+{
+
+  return inquire_access (string, len, R_OK);
+}
+
+
+/* inquire_write()-- Given a fortran string, determine if the file is
+ * suitable for READ access. */
+
+const char *
+inquire_write (const char *string, int len)
+{
+
+  return inquire_access (string, len, W_OK);
+}
+
+
+/* inquire_readwrite()-- Given a fortran string, determine if the file is
+ * suitable for read and write access. */
+
+const char *
+inquire_readwrite (const char *string, int len)
+{
+
+  return inquire_access (string, len, R_OK | W_OK);
+}
+
+
+/* file_length()-- Return the file length in bytes, -1 if unknown */
+
+offset_t
+file_length (stream * s)
+{
+
+  return ((unix_stream *) s)->file_length;
+}
+
+
+/* file_position()-- Return the current position of the file */
+
+offset_t
+file_position (stream * s)
+{
+
+  return ((unix_stream *) s)->logical_offset;
+}
+
+
+/* is_seekable()-- Return nonzero if the stream is seekable, zero if
+ * it is not */
+
+int
+is_seekable (stream * s)
+{
+
+  return ((unix_stream *) s)->mmaped;
+}
+
+
+/* How files are stored:  This is an operating-system specific issue,
+   and therefore belongs here.  There are three cases to consider.
+
+   Direct Access:
+      Records are written as block of bytes corresponding to the record
+      length of the file.  This goes for both formatted and unformatted
+      records.  Positioning is done explicitly for each data transfer,
+      so positioning is not much of an issue.
+
+   Sequential Formatted:
+      Records are separated by newline characters.  The newline character
+      is prohibited from appearing in a string.  If it does, this will be
+      messed up on the next read.  End of file is also the end of a record.
+
+   Sequential Unformatted:
+      In this case, we are merely copying bytes to and from main storage,
+      yet we need to keep track of varying record lengths.  We adopt
+      the solution used by f2c.  Each record contains a pair of length
+      markers:
+
+        Length of record n in bytes
+        Data of record n
+        Length of record n in bytes
+
+        Length of record n+1 in bytes
+        Data of record n+1
+        Length of record n+1 in bytes
+
+     The length is stored at the end of a record to allow backspacing to the
+     previous record.  Between data transfer statements, the file pointer
+     is left pointing to the first length of the current record.
+
+     ENDFILE records are never explicitly stored.
+
+*/
diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c
new file mode 100644
index 0000000..dd44f6e
--- /dev/null
+++ b/libgfortran/io/write.c
@@ -0,0 +1,1129 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <string.h>
+#include <float.h>
+#include "libgfortran.h"
+#include "io.h"
+#include <stdio.h>
+
+
+#define star_fill(p, n) memset(p, '*', n)
+
+
+typedef enum
+{ SIGN_NONE, SIGN_MINUS, SIGN_PLUS }
+sign_t;
+
+
+void
+write_a (fnode * f, const char *source, int len)
+{
+  int wlen;
+  char *p;
+
+  wlen = f->u.string.length < 0 ? len : f->u.string.length;
+
+  p = write_block (wlen);
+  if (p == NULL)
+    return;
+
+  if (wlen < len)
+    memcpy (p, source, wlen);
+  else
+    {
+      memcpy (p, source, len);
+      memset (p + len, ' ', wlen - len);
+    }
+}
+
+static int64_t
+extract_int (const void *p, int len)
+{
+  int64_t i = 0;
+
+  if (p == NULL)
+    return i;
+
+  switch (len)
+    {
+    case 1:
+      i = *((const int8_t *) p);
+      break;
+    case 2:
+      i = *((const int16_t *) p);
+      break;
+    case 4:
+      i = *((const int32_t *) p);
+      break;
+    case 8:
+      i = *((const int64_t *) p);
+      break;
+    default:
+      internal_error ("bad integer kind");
+    }
+
+  return i;
+}
+
+static double
+extract_real (const void *p, int len)
+{
+  double i = 0.0;
+  switch (len)
+    {
+    case 4:
+      i = *((const float *) p);
+      break;
+    case 8:
+      i = *((const double *) p);
+      break;
+    default:
+      internal_error ("bad real kind");
+    }
+  return i;
+
+}
+
+
+/* calculate sign()-- Given a flag that indicate if a value is
+ * negative or not, return a sign_t that gives the sign that we need
+ * to produce. */
+
+static sign_t
+calculate_sign (int negative_flag)
+{
+  sign_t s = SIGN_NONE;
+
+  if (negative_flag)
+    s = SIGN_MINUS;
+  else
+    switch (g.sign_status)
+      {
+      case SIGN_SP:
+	s = SIGN_PLUS;
+	break;
+      case SIGN_SS:
+	s = SIGN_NONE;
+	break;
+      case SIGN_S:
+	s = options.optional_plus ? SIGN_PLUS : SIGN_NONE;
+	break;
+      }
+
+  return s;
+}
+
+
+/* calculate_exp()-- returns the value of 10**d.  */
+
+static double
+calculate_exp (int d)
+{
+  int i;
+  double r = 1.0;
+
+  for (i = 0; i< (d >= 0 ? d : -d); i++)
+    r *= 10;
+
+  r = (d >= 0) ? r : 1.0 / r;
+
+  return r;
+}
+
+
+/* calculate_G_format()-- geneate corresponding I/O format for
+   FMT_G output.
+   The rules to translate FMT_G to FMT_E or FNT_F from DEC fortran
+   LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
+
+   Data Magnitude                              Equivalent Conversion
+   0< m < 0.1-0.5*10**(-d-1)                   Ew.d[Ee]
+   m = 0                                       F(w-n).(d-1), n' '
+   0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d)     F(w-n).d, n' '
+   1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1)      F(w-n).(d-1), n' '
+   10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2)  F(w-n).(d-2), n' '
+   ................                           ..........
+   10**(d-1)-0.5*10**(-1)<= m <10**d-0.5       F(w-n).0,n(' ')
+   m >= 10**d-0.5                              Ew.d[Ee]
+
+   notes: for Gw.d ,  n' ' means 4 blanks
+          for Gw.dEe, n' ' means e+2 blanks  */
+
+static fnode *
+calculate_G_format (fnode *f, double value, int len, int *num_blank)
+{
+  int e = f->u.real.e;
+  int d = f->u.real.d;
+  int w = f->u.real.w;
+  fnode *newf;
+  double m, exp_d;
+  int low, high, mid;
+  int ubound, lbound;
+
+  newf = get_mem (sizeof (fnode));
+
+  /* Absolute value.  */
+  m = (value > 0.0) ? value : -value;
+
+  /* In case of the two data magnitude ranges,
+     generate E editing, Ew.d[Ee].  */
+  exp_d = calculate_exp (d);
+  if ((m > 0.0 && m < 0.1 - 0.05 / (double) exp_d)
+      || (m >= (double) exp_d - 0.5 ))
+    {
+      newf->format = FMT_E;
+      newf->u.real.w = w;
+      newf->u.real.d = d;
+      newf->u.real.e = e;
+      *num_blank = e + 2;
+      return newf;
+    }
+
+  /* Use binary search to find the data magnitude range.  */
+  mid = 0;
+  low = 0;
+  high = d + 1;
+  lbound = 0;
+  ubound = d + 1;
+
+  while (low <= high)
+    {
+      double temp;
+      mid = (low + high) / 2;
+
+      /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1)  */
+      temp = 0.1 * calculate_exp (mid) - 0.5 * calculate_exp (mid - d - 1);
+
+      if (m < temp)
+        {
+          ubound = mid;
+          if (ubound == lbound + 1)
+            break;
+          high = mid - 1;
+        }
+      else if (m > temp)
+        {
+          lbound = mid;
+          if (ubound == lbound + 1)
+            {
+              mid ++;
+              break;
+            }
+          low = mid + 1;
+        }
+      else
+        break;
+    }
+
+  /* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '.  */
+  newf->format = FMT_F;
+  newf->u.real.w = f->u.real.w - 4;
+
+  /* Special case.  */
+  if (m == 0.0)
+    newf->u.real.d = d - 1;
+  else
+    newf->u.real.d = - (mid - d - 1);
+
+  *num_blank = 4;
+
+  /* For F editing, the scale factor is ignored.  */
+  g.scale_factor = 0;
+  return newf;
+}
+
+
+/* output_float() -- output a real number according to its format
+                     which is FMT_G free */
+
+static void
+output_float (fnode *f, double value, int len)
+{
+  int w, d, e, e_new;
+  int digits;
+  int nsign, nblank, nesign;
+  int sca, neval, itmp;
+  char *p;
+  const char *q, *intstr, *base;
+  double n;
+  format_token ft;
+  char exp_char = 'E';
+  int with_exp = 1;
+  int scale_flag = 1 ;
+  double minv = 0.0, maxv = 0.0;
+  sign_t sign = SIGN_NONE, esign = SIGN_NONE;
+
+  int intval = 0, intlen = 0;
+  int j;
+  
+  /* EXP value for this number */
+  neval = 0;
+
+  /* Width of EXP and it's sign*/
+  nesign = 0;
+
+  ft = f->format;
+  w = f->u.real.w;
+  d = f->u.real.d + 1;
+
+  /* Width of the EXP */
+  e = 0;
+
+  sca = g.scale_factor;
+  n = value;
+
+  sign = calculate_sign (n < 0.0);
+  if (n < 0)
+    n = -n;
+
+  /* Width of the sign for the whole number */
+  nsign = (sign == SIGN_NONE ? 0 : 1);
+
+  digits = 0;
+  if (ft != FMT_F)
+    {
+      e = f->u.real.e;
+    }
+  if (ft == FMT_F || ft == FMT_E || ft == FMT_D)
+    {
+      if (ft == FMT_F)
+        scale_flag = 0;
+      if (ft == FMT_D)
+        exp_char = 'D' ;
+      minv = 0.1;
+      maxv = 1.0;
+
+      /* Here calculate the new val of the number with consideration
+         of Globle Scale value */
+      while (sca >  0)
+        {
+          minv *= 10.0;
+          maxv *= 10.0;
+          n *= 10.0;
+          sca -- ;
+          neval --;
+        }
+
+      /* Now calculate the new Exp value for this number */
+      sca = g.scale_factor;
+      while(sca >= 1)
+        {
+          sca /= 10;
+          digits ++ ;
+        }
+    }
+
+   if (ft == FMT_EN )
+     {
+       minv = 1.0;
+       maxv = 1000.0;
+     }
+   if (ft == FMT_ES)
+     {
+       minv = 1.0;
+       maxv = 10.0;
+     }
+
+   /* OK, let's scale the number to appropriate range */
+   while (scale_flag && n > 0.0 && n < minv)
+     {
+       if (n < minv)
+         {
+           n = n * 10.0 ;
+           neval --;
+         }
+     }
+   while (scale_flag && n > 0.0 && n > maxv)
+     {
+       if (n > maxv)
+         {
+           n = n / 10.0 ;
+           neval ++;
+         }
+     }
+
+  /* It is time to process the EXP part of the number. 
+     Value of 'nesign' is 0 unless following codes is executed.
+  */
+  if (ft != FMT_F)
+    {
+     /* Sign of the EXP value */
+     if (neval >= 0)
+       esign = SIGN_PLUS;
+     else
+       {
+         esign = SIGN_MINUS;
+         neval = - neval ;
+       }
+
+      /* Width of the EXP*/
+      e_new = 0;
+      j = neval;
+      while (j > 0)
+        {
+           j = j / 10;
+           e_new ++ ;
+        }
+      if (e <= e_new)
+         e = e_new;
+
+     /* Got the width of EXP */
+     if (e < digits)
+       e = digits ;
+
+     /* Minimum value of the width would be 2 */
+     if (e < 2)
+       e = 2;
+
+     nesign =  1 ;  /* We must give a position for the 'exp_char' */
+     if (e > 0)
+       nesign = e + nesign + (esign != SIGN_NONE ? 1 : 0);
+   }
+
+
+  intval = n;
+  intstr = itoa (intval);
+  intlen = strlen (intstr);
+
+  q = rtoa (n, len, d);
+  digits = strlen (q);
+
+  /* Select a width if none was specified.  */
+  if (w <= 0)
+    w = digits + nsign;
+
+  p = write_block (w);
+  if (p == NULL)
+    return;
+
+  base = p;
+
+  nblank = w - (nsign + intlen + d + nesign);
+  if (nblank == -1 && ft != FMT_F)
+     {
+       with_exp = 0;
+       nesign -= 1;
+       nblank = w - (nsign + intlen + d + nesign);
+     }
+  /* don't let a leading '0' cause field overflow */
+  if (nblank == -1 && ft == FMT_F && q[0] == '0')
+     {
+        q++;
+        nblank = 0;
+     }
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+  memset (p, ' ', nblank);
+  p += nblank;
+
+  switch (sign)
+    {
+    case SIGN_PLUS:
+      *p++ = '+';
+      break;
+    case SIGN_MINUS:
+      *p++ = '-';
+      break;
+    case SIGN_NONE:
+      break;
+    }
+
+  memcpy (p, q, intlen + d + 1);
+  p += intlen + d;
+
+  if (nesign > 0)
+    {
+      if (with_exp)
+         *p++ = exp_char;
+      switch (esign)
+        {
+        case SIGN_PLUS:
+          *p++ = '+';
+          break;
+        case SIGN_MINUS:
+          *p++ = '-';
+          break;
+        case SIGN_NONE:
+          break;
+        }
+      q = itoa (neval);
+      digits = strlen (q);
+
+      for (itmp = 0; itmp < e - digits; itmp++)
+        *p++ = '0';
+      memcpy (p, q, digits);
+      p[digits]  = 0;
+    }
+
+done:
+  return ;
+}
+
+void
+write_l (fnode * f, char *source, int len)
+{
+  char *p;
+  int64_t n;
+                                                                                
+  p = write_block (f->u.w);
+  if (p == NULL)
+    return;
+
+  memset (p, ' ', f->u.w - 1);
+  n = extract_int (source, len);
+  p[f->u.w - 1] = (n) ? 'T' : 'F';
+}
+
+/* write_float() -- output a real number according to its format */
+
+static void
+write_float (fnode *f, const char *source, int len)
+{
+  double n;
+  int nb =0, res;
+  char * p, fin;
+  fnode *f2 = NULL;
+
+  n = extract_real (source, len);
+
+  if (f->format != FMT_B && f->format != FMT_O && f->format != FMT_Z)
+   {
+     res = finite (n);
+     if (res == 0)
+       {
+         nb =  f->u.real.w;
+         if (nb <= 4)
+            nb = 4;
+         p = write_block (nb);
+         memset (p, ' ' , 1);
+         
+         res = isinf (n);
+         if (res != 0)
+         {
+            if (res > 0)
+               fin = '+';
+            else
+               fin = '-';
+         
+             memset (p + 1, fin, nb - 1);
+          }
+         else
+             sprintf(p + 1, "NaN");
+         return;
+       }
+   }
+
+  if (f->format != FMT_G)
+    {
+      output_float (f, n, len);
+    }
+  else
+    {
+      f2 = calculate_G_format(f, n, len, &nb);
+      output_float (f2, n, len);
+      if (f2 != NULL)
+        free_mem(f2);
+
+      if (nb > 0)
+        {
+          p = write_block (nb);
+          memset (p, ' ', nb);
+        }
+   }
+}
+
+
+static void
+write_int (fnode *f, const char *source, int len, char *(*conv) (uint64_t))
+{
+  uint32_t ns =0;
+  uint64_t n = 0;
+  int w, m, digits, nzero, nblank;
+  char *p, *q;
+
+  w = f->u.integer.w;
+  m = f->u.integer.m;
+
+  n = extract_int (source, len);
+
+  /* Special case */
+
+  if (m == 0 && n == 0)
+    {
+      if (w == 0)
+        w = 1;
+
+      p = write_block (w);
+      if (p == NULL)
+        return;
+
+      memset (p, ' ', w);
+      goto done;
+    }
+
+
+  if (len < 8)
+     {
+       ns = n;
+       q = conv (ns);
+     }
+  else
+      q = conv (n);
+
+  digits = strlen (q);
+
+  /* Select a width if none was specified.  The idea here is to always
+   * print something. */
+
+  if (w == 0)
+    w = ((digits < m) ? m : digits);
+
+  p = write_block (w);
+  if (p == NULL)
+    return;
+
+  nzero = 0;
+  if (digits < m)
+    nzero = m - digits;
+
+  /* See if things will work */
+
+  nblank = w - (nzero + digits);
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+
+  memset (p, ' ', nblank);
+  p += nblank;
+
+  memset (p, '0', nzero);
+  p += nzero;
+
+  memcpy (p, q, digits);
+
+done:
+  return;
+}
+
+static void
+write_decimal (fnode *f, const char *source, int len, char *(*conv) (int64_t))
+{
+  int64_t n = 0;
+  int w, m, digits, nsign, nzero, nblank;
+  char *p, *q;
+  sign_t sign;
+
+  w = f->u.integer.w;
+  m = f->u.integer.m;
+
+  n = extract_int (source, len);
+
+  /* Special case */
+
+  if (m == 0 && n == 0)
+    {
+      if (w == 0)
+        w = 1;
+
+      p = write_block (w);
+      if (p == NULL)
+        return;
+
+      memset (p, ' ', w);
+      goto done;
+    }
+
+  sign = calculate_sign (n < 0);
+  if (n < 0)
+    n = -n;
+
+  nsign = sign == SIGN_NONE ? 0 : 1;
+  q = conv (n);
+
+  digits = strlen (q);
+
+  /* Select a width if none was specified.  The idea here is to always
+   * print something. */
+
+  if (w == 0)
+    w = ((digits < m) ? m : digits) + nsign;
+
+  p = write_block (w);
+  if (p == NULL)
+    return;
+
+  nzero = 0;
+  if (digits < m)
+    nzero = m - digits;
+
+  /* See if things will work */
+
+  nblank = w - (nsign + nzero + digits);
+
+  if (nblank < 0)
+    {
+      star_fill (p, w);
+      goto done;
+    }
+
+  memset (p, ' ', nblank);
+  p += nblank;
+
+  switch (sign)
+    {
+    case SIGN_PLUS:
+      *p++ = '+';
+      break;
+    case SIGN_MINUS:
+      *p++ = '-';
+      break;
+    case SIGN_NONE:
+      break;
+    }
+
+  memset (p, '0', nzero);
+  p += nzero;
+
+  memcpy (p, q, digits);
+
+done:
+  return;
+}
+
+
+/* otoa()-- Convert unsigned octal to ascii */
+
+static char *
+otoa (uint64_t n)
+{
+  char *p;
+
+  if (n == 0)
+    {
+      scratch[0] = '0';
+      scratch[1] = '\0';
+      return scratch;
+    }
+
+  p = scratch + sizeof (SCRATCH_SIZE) - 1;
+  *p-- = '\0';
+
+  while (n != 0)
+    {
+      *p = '0' + (n & 7);
+      p -- ;
+      n >>= 3;
+    }
+
+  return ++p;
+}
+
+
+/* btoa()-- Convert unsigned binary to ascii */
+
+static char *
+btoa (uint64_t n)
+{
+  char *p;
+
+  if (n == 0)
+    {
+      scratch[0] = '0';
+      scratch[1] = '\0';
+      return scratch;
+    }
+
+  p = scratch + sizeof (SCRATCH_SIZE) - 1;
+  *p-- = '\0';
+
+  while (n != 0)
+    {
+      *p-- = '0' + (n & 1);
+      n >>= 1;
+    }
+
+  return ++p;
+}
+
+
+void
+write_i (fnode * f, const char *p, int len)
+{
+
+  write_decimal (f, p, len, (void *) itoa);
+}
+
+
+void
+write_b (fnode * f, const char *p, int len)
+{
+
+  write_int (f, p, len, btoa);
+}
+
+
+void
+write_o (fnode * f, const char *p, int len)
+{
+
+  write_int (f, p, len, otoa);
+}
+
+void
+write_z (fnode * f, const char *p, int len)
+{
+
+  write_int (f, p, len, xtoa);
+}
+
+
+void
+write_d (fnode *f, const char *p, int len)
+{
+  write_float (f, p, len);
+}
+
+
+void
+write_e (fnode *f, const char *p, int len)
+{
+  write_float (f, p, len);
+}
+
+
+void
+write_f (fnode *f, const char *p, int len)
+{
+  write_float (f, p, len);
+}
+
+
+void
+write_en (fnode *f, const char *p, int len)
+{
+  write_float (f, p, len);
+}
+
+
+void
+write_es (fnode *f, const char *p, int len)
+{
+  write_float (f, p, len);
+}
+
+
+/* write_x()-- Take care of the X/TR descriptor */
+
+void
+write_x (fnode * f)
+{
+  char *p;
+
+  p = write_block (f->u.n);
+  if (p == NULL)
+    return;
+
+  memset (p, ' ', f->u.n);
+}
+
+
+/* List-directed writing */
+
+
+/* write_char()-- Write a single character to the output.  Returns
+ * nonzero if something goes wrong. */
+
+static int
+write_char (char c)
+{
+  char *p;
+
+  p = write_block (1);
+  if (p == NULL)
+    return 1;
+
+  *p = c;
+
+  return 0;
+}
+
+
+/* write_logical()-- Write a list-directed logical value */
+/* Default logical output should be L2
+  according to DEC fortran Manual. */
+static void
+write_logical (const char *source, int length)
+{
+  write_char (' ');
+  write_char (extract_int (source, length) ? 'T' : 'F');
+}
+
+
+/* write_integer()-- Write a list-directed integer value. */
+
+static void
+write_integer (const char *source, int length)
+{
+  char *p;
+  const char *q;
+  int digits;
+  int width = 12;
+
+  q = itoa (extract_int (source, length));
+
+  digits = strlen (q);
+
+  if(width < digits )
+    width = digits ;
+  p = write_block (width) ;
+
+  memset(p ,' ', width - digits) ;
+  memcpy (p + width - digits, q, digits);
+}
+
+
+/* write_character()-- Write a list-directed string.  We have to worry
+ * about delimiting the strings if the file has been opened in that
+ * mode. */
+
+static void
+write_character (const char *source, int length)
+{
+  int i, extra;
+  char *p, d;
+
+  switch (current_unit->flags.delim)
+    {
+    case DELIM_APOSTROPHE:
+      d = '\'';
+      break;
+    case DELIM_QUOTE:
+      d = '"';
+      break;
+    default:
+      d = ' ';
+      break;
+    }
+
+  if (d == ' ')
+    extra = 0;
+  else
+    {
+      extra = 2;
+
+      for (i = 0; i < length; i++)
+	if (source[i] == d)
+	  extra++;
+    }
+
+  p = write_block (length + extra);
+  if (p == NULL)
+    return;
+
+  if (d == ' ')
+    memcpy (p, source, length);
+  else
+    {
+      *p++ = d;
+
+      for (i = 0; i < length; i++)
+	{
+	  *p++ = source[i];
+	  if (source[i] == d)
+	    *p++ = d;
+	}
+
+      *p = d;
+    }
+}
+
+
+/* Output the Real number with default format.
+   According to DEC fortran LRM, default format for
+   REAL(4) is 1PG15.7E2, and for REAL(8) is 1PG25.15E3  */
+
+static void
+write_real (const char *source, int length)
+{
+  fnode f ;
+  int org_scale = g.scale_factor;
+  f.format = FMT_G;
+  g.scale_factor = 1;
+  if (length < 8)
+    {
+      f.u.real.w = 15;
+      f.u.real.d = 7;
+      f.u.real.e = 2;
+    }
+  else
+    {
+      f.u.real.w = 24;
+      f.u.real.d = 15;
+      f.u.real.e = 3;
+    }
+  write_float (&f, source , length);
+  g.scale_factor = org_scale;
+}
+
+
+static void
+write_complex (const char *source, int len)
+{
+
+  if (write_char ('('))
+    return;
+  write_real (source, len);
+
+  if (write_char (','))
+    return;
+  write_real (source + len, len);
+
+  write_char (')');
+}
+
+
+/* write_separator()-- Write the separator between items. */
+
+static void
+write_separator (void)
+{
+  char *p;
+
+  p = write_block (options.separator_len);
+  if (p == NULL)
+    return;
+
+  memcpy (p, options.separator, options.separator_len);
+}
+
+
+/* list_formatted_write()-- Write an item with list formatting.
+ * TODO: handle skipping to the next record correctly, particularly
+ * with strings. */
+
+void
+list_formatted_write (bt type, void *p, int len)
+{
+  static int char_flag;
+
+  if (current_unit == NULL)
+    return;
+
+  if (g.first_item)
+    {
+      g.first_item = 0;
+      char_flag = 0;
+    }
+  else
+    {
+      if (type != BT_CHARACTER || !char_flag ||
+	  current_unit->flags.delim != DELIM_NONE)
+	write_separator ();
+    }
+
+  switch (type)
+    {
+    case BT_INTEGER:
+      write_integer (p, len);
+      break;
+    case BT_LOGICAL:
+      write_logical (p, len);
+      break;
+    case BT_CHARACTER:
+      write_character (p, len);
+      break;
+    case BT_REAL:
+      write_real (p, len);
+      break;
+    case BT_COMPLEX:
+      write_complex (p, len);
+      break;
+    default:
+      internal_error ("list_formatted_write(): Bad type");
+    }
+
+  char_flag = (type == BT_CHARACTER);
+}
+
+void
+namelist_write (void)
+{
+   namelist_info * t1, *t2;
+   int len,num;
+   void * p;
+
+   num = 0;
+   write_character("&",1);
+   write_character (ioparm.namelist_name, ioparm.namelist_name_len);
+   write_character("\n",1);
+
+   if (ionml != NULL)
+     {
+       t1 = ionml;
+       while (t1 != NULL)
+        {
+          num ++;
+          t2 = t1;
+          t1 = t1->next;
+          write_character(t2->var_name, strlen(t2->var_name));
+          write_character("=",1);
+          len = t2->len;
+          p = t2->mem_pos;
+          switch (t2->type)
+            {
+            case BT_INTEGER:
+              write_integer (p, len);
+              break;
+            case BT_LOGICAL:
+              write_logical (p, len);
+              break;
+            case BT_CHARACTER:
+              write_character (p, len);
+              break;
+            case BT_REAL:
+              write_real (p, len);
+              break;
+            case BT_COMPLEX:
+              write_complex (p, len);
+              break;
+            default:
+              internal_error ("Bad type for namelist write");
+            }
+         write_character(",",1);
+         if (num > 5)
+           {
+              num = 0;
+              write_character("\n",1);
+           }
+        }
+     }
+     write_character("/",1);
+
+}
+