gfortran ChangeLog

2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	PR fortran/24174
	PR fortran/24305
	* fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
	argument to transfer_array.
	(transfer_array_desc): Add kind argument.

testsuite ChangeLog:

2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	PR fortran/24174
	PR fortran/24305
	* testsuite/gfortran.dg/large_real_kind_form_io_1.f90: New file.

libgfortran Changelog:

2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>

	PR fortran/24174
	PR fortran/24305
	* io/io.h: Add argument to prototypes, add prototypes for
	size_from_*_kind functions.
	* io/list_read.c (read_complex): Add size argument, use
	it. 
	(list_formatted_read): Add size argument, cleanup.
	(list_formatted_read_scalar): Add size argument.
	(nml_read_obj): Fix for padding.
	* io/transfer.c: Add argument to transfer function pointer.
	(unformatted_read): Add size argument.
	(unformatted_write): Likewise.
	(formatted_transfer_scalar): Fix for padding with complex(10).
	(formatted_transfer): Add size argument, cleanup.
	(transfer_integer): Add size argument to transfer call.
	(transfer_real): Likewise.
	(transfer_logical): Likewise.
	(transfer_character): Likewise.
	(transfer_complex): Likewise.
	(transfer_array): New kind argument, use it.
	(data_transfer_init): Add size argument to formatted_transfer
	call.
	(iolength_transfer): Add size argument, cleanup.
	* io/write.c (write_complex): Add size argument, fix for padding
	with complex(10).
	(list_formatted_write): Add size argument, cleanup.
	(list_formatted_write_scalar): Add size argument, use it.
	(nml_write_obj): Fix for size vs. kind issue.
	* io/size_from_kind.c: New file.
	* Makefile.am: Add io/size_from_kind.c.
	* configure: Regenerate.
	* Makefile.in: Regenerate.

From-SVN: r106563

gcc/fortran/ChangeLog

+2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
+
+	PR fortran/24174
+	PR fortran/24305
+	* fortran/trans-io.c (gfc_build_io_library_fndecls): Add kind
+	argument to transfer_array.
+	(transfer_array_desc): Add kind argument.
+
 2005-11-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* intrinsic.c (add_functions): Add ctime and fdate intrinsics.

gcc/fortran/trans-io.c

@@ -159,10 +159,12 @@ gfc_build_io_library_fndecls (void)
 {
   tree gfc_int4_type_node;
   tree gfc_pint4_type_node;
+  tree gfc_c_int_type_node;
   tree ioparm_type;
 
   gfc_int4_type_node = gfc_get_int_type (4);
   gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
+  gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
 
   /* Build the st_parameter structure.  Information associated with I/O
      calls are transferred here.  This must match the one defined in the
@@ -271,7 +273,8 @@ gfc_build_io_library_fndecls (void)
   iocall_x_array =
     gfc_build_library_function_decl (get_identifier
 				     (PREFIX("transfer_array")),
-				     void_type_node, 2, pvoid_type_node,
+				     void_type_node, 3, pvoid_type_node,
+				     gfc_c_int_type_node,
 				     gfc_charlen_type_node);
 
   /* Library entry points */
@@ -1597,14 +1600,17 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 static void
 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
 {
-  tree args, tmp, charlen_arg;
+  tree args, tmp, charlen_arg, kind_arg;
 
   if (ts->type == BT_CHARACTER)
     charlen_arg = se->string_length;
   else
     charlen_arg = build_int_cstu (NULL_TREE, 0);
 
+  kind_arg = build_int_cst (NULL_TREE, ts->kind);
+
   args = gfc_chainon_list (NULL_TREE, addr_expr);
+  args = gfc_chainon_list (args, kind_arg);
   args = gfc_chainon_list (args, charlen_arg);
   tmp = gfc_build_function_call (iocall_x_array, args);
   gfc_add_expr_to_block (&se->pre, tmp);

gcc/testsuite/ChangeLog

+2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
+
+	PR fortran/24174
+	PR fortran/24305
+	* testsuite/gfortran.dg/large_real_kind_form_io_1.f90: New file.	
+
 2005-11-06  Diego Novillo  <dnovillo@redhat.com>
 
 	PR 24670

gcc/testsuite/gfortran.dg/large_real_kind_form_io_1.f90

+! { dg-do run }
+! { dg-require-effective-target fortran_large_real }
+! PR 24174 and PR 24305
+program large_real_kind_form_io_1
+  ! This should be 10 on systems that support kind=10
+  integer, parameter :: k = selected_real_kind (precision (0.0_8) + 1)
+  real(kind=k) :: a,b(2), c, eps
+  complex(kind=k) :: d, e, f(2), g
+  character(len=180) :: tmp
+  ! Test real(k) scalar and array formatted IO
+  eps = 10 * spacing (2.0_k) ! 10 ulp precision is enough.
+  b(:) = 2.0_k
+  write (tmp, *) b
+  read (tmp, *) a, c
+  if (abs (a - b(1)) > eps) call abort ()
+  if (abs (c - b(2)) > eps) call abort ()
+  ! Complex(k) scalar and array formatted and list formatted IO
+  d = cmplx ( 1.0_k, 2.0_k, k)
+  f = d
+  write (tmp, *) f
+  read (tmp, *) e, g
+  if (abs (e - d) > eps) call abort ()
+  if (abs (g - d) > eps) call abort ()
+  write (tmp, '(2(e12.4e5, 2x))') d
+  read (tmp, '(2(e12.4e5, 2x))') e
+  if (abs (e - d) > eps) call abort()
+end program large_real_kind_form_io_1

libgfortran/ChangeLog

+2005-11-06  Janne Blomqvist <jb@gcc.gnu.org>
+
+	PR fortran/24174
+	PR fortran/24305
+	* io/io.h: Add argument to prototypes, add prototypes for
+	size_from_*_kind functions.
+	* io/list_read.c (read_complex): Add size argument, use
+	it. 
+	(list_formatted_read): Add size argument, cleanup.
+	(list_formatted_read_scalar): Add size argument.
+	(nml_read_obj): Fix for padding.
+	* io/transfer.c: Add argument to transfer function pointer.
+	(unformatted_read): Add size argument.
+	(unformatted_write): Likewise.
+	(formatted_transfer_scalar): Fix for padding with complex(10).
+	(formatted_transfer): Add size argument, cleanup.
+	(transfer_integer): Add size argument to transfer call.
+	(transfer_real): Likewise.
+	(transfer_logical): Likewise.
+	(transfer_character): Likewise.
+	(transfer_complex): Likewise.
+	(transfer_array): New kind argument, use it.
+	(data_transfer_init): Add size argument to formatted_transfer
+	call.
+	(iolength_transfer): Add size argument, cleanup.
+	* io/write.c (write_complex): Add size argument, fix for padding
+	with complex(10).
+	(list_formatted_write): Add size argument, cleanup.
+	(list_formatted_write_scalar): Add size argument, use it.
+	(nml_write_obj): Fix for size vs. kind issue.
+	* io/size_from_kind.c: New file.
+	* Makefile.am: Add io/size_from_kind.c.
+	* configure: Regenerate.
+	* Makefile.in: Regenerate.
+
 2005-11-06  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
 
 	* intrinsics/ctime.c: New file.

libgfortran/Makefile.am

@@ -27,6 +27,7 @@ io/list_read.c \
 io/lock.c \
 io/open.c \
 io/read.c \
+io/size_from_kind.c \
 io/transfer.c \
 io/unit.c \
 io/unix.c \

libgfortran/Makefile.in

@@ -162,8 +162,8 @@ am__objects_31 = $(am__objects_2) $(am__objects_3) $(am__objects_4) \
 	$(am__objects_26) $(am__objects_27) $(am__objects_28) \
 	$(am__objects_29) $(am__objects_30)
 am__objects_32 = close.lo file_pos.lo format.lo inquire.lo \
-	list_read.lo lock.lo open.lo read.lo transfer.lo unit.lo \
-	unix.lo write.lo
+	list_read.lo lock.lo open.lo read.lo size_from_kind.lo \
+	transfer.lo unit.lo unix.lo write.lo
 am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
 	c99_functions.lo chdir.lo cpu_time.lo cshift0.lo ctime.lo \
 	date_and_time.lo env.lo erf.lo eoshift0.lo eoshift2.lo \
@@ -368,6 +368,7 @@ io/list_read.c \
 io/lock.c \
 io/open.c \
 io/read.c \
+io/size_from_kind.c \
 io/transfer.c \
 io/unit.c \
 io/unix.c \
@@ -2200,6 +2201,9 @@ open.lo: io/open.c
 read.lo: io/read.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o read.lo `test -f 'io/read.c' || echo '$(srcdir)/'`io/read.c
 
+size_from_kind.lo: io/size_from_kind.c
+	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size_from_kind.lo `test -f 'io/size_from_kind.c' || echo '$(srcdir)/'`io/size_from_kind.c
+
 transfer.lo: io/transfer.c
 	$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o transfer.lo `test -f 'io/transfer.c' || echo '$(srcdir)/'`io/transfer.c
 

libgfortran/io/io.h

@@ -627,7 +627,7 @@ internal_proto(read_decimal);
 
 /* list_read.c */
 
-extern void list_formatted_read (bt, void *, int, size_t);
+extern void list_formatted_read (bt, void *, int, size_t, size_t);
 internal_proto(list_formatted_read);
 
 extern void finish_list_read (void);
@@ -680,11 +680,18 @@ internal_proto(write_x);
 extern void write_z (fnode *, const char *, int);
 internal_proto(write_z);
 
-extern void list_formatted_write (bt, void *, int, size_t);
+extern void list_formatted_write (bt, void *, int, size_t, size_t);
 internal_proto(list_formatted_write);
 
 /* error.c */
 extern try notify_std (int, const char *);
 internal_proto(notify_std);
 
+/* size_from_kind.c */
+extern size_t size_from_real_kind (int);
+internal_proto(size_from_real_kind);
+
+extern size_t size_from_complex_kind (int);
+internal_proto(size_from_complex_kind);
+
 #endif

libgfortran/io/list_read.c

@@ -958,7 +958,7 @@ parse_real (void *buffer, int length)
    what it is right away.  */
 
 static void
-read_complex (int length)
+read_complex (int kind, size_t size)
 {
   char message[100];
   char c;
@@ -982,7 +982,7 @@ read_complex (int length)
     }
 
   eat_spaces ();
-  if (parse_real (value, length))
+  if (parse_real (value, kind))
     return;
 
 eol_1:
@@ -1004,7 +1004,7 @@ eol_2:
   else
     unget_char (c);
 
-  if (parse_real (value + length, length))
+  if (parse_real (value + size / 2, kind))
     return;
 
   eat_spaces ();
@@ -1287,7 +1287,7 @@ check_type (bt type, int len)
    greater than one, we copy the data item multiple times.  */
 
 static void
-list_formatted_read_scalar (bt type, void *p, int len)
+list_formatted_read_scalar (bt type, void *p, int kind, size_t size)
 {
   char c;
   int m;
@@ -1326,7 +1326,7 @@ list_formatted_read_scalar (bt type, void *p, int len)
 
       if (repeat_count > 0)
 	{
-	  if (check_type (type, len))
+	  if (check_type (type, kind))
 	    return;
 	  goto set_value;
 	}
@@ -1348,26 +1348,26 @@ list_formatted_read_scalar (bt type, void *p, int len)
   switch (type)
     {
     case BT_INTEGER:
-      read_integer (len);
+      read_integer (kind);
       break;
     case BT_LOGICAL:
-      read_logical (len);
+      read_logical (kind);
       break;
     case BT_CHARACTER:
-      read_character (len);
+      read_character (kind);
       break;
     case BT_REAL:
-      read_real (len);
+      read_real (kind);
       break;
     case BT_COMPLEX:
-      read_complex (len);
+      read_complex (kind, size);
       break;
     default:
       internal_error ("Bad type for list read");
     }
 
   if (saved_type != BT_CHARACTER && saved_type != BT_NULL)
-    saved_length = len;
+    saved_length = size;
 
   if (ioparm.library_return != LIBRARY_OK)
     return;
@@ -1376,27 +1376,24 @@ list_formatted_read_scalar (bt type, void *p, int len)
   switch (saved_type)
     {
     case BT_COMPLEX:
-      len = 2 * len;
-      /* Fall through.  */
-
     case BT_INTEGER:
     case BT_REAL:
     case BT_LOGICAL:
-      memcpy (p, value, len);
+      memcpy (p, value, size);
       break;
 
     case BT_CHARACTER:
       if (saved_string)
        {
-          m = (len < saved_used) ? len : saved_used;
+          m = ((int) size < saved_used) ? (int) size : saved_used;
           memcpy (p, saved_string, m);
        }
       else
 	/* Just delimiters encountered, nothing to copy but SPACE.  */
         m = 0;
 
-      if (m < len)
-	memset (((char *) p) + m, ' ', len - m);
+      if (m < (int) size)
+	memset (((char *) p) + m, ' ', size - m);
       break;
 
     case BT_NULL:
@@ -1409,24 +1406,18 @@ list_formatted_read_scalar (bt type, void *p, int len)
 
 
 void
-list_formatted_read  (bt type, void *p, int len, size_t nelems)
+list_formatted_read  (bt type, void *p, int kind, size_t size, size_t nelems)
 {
   size_t elem;
-  int size;
   char *tmp;
 
   tmp = (char *) p;
 
-  if (type == BT_COMPLEX)
-    size = 2 * len;
-  else
-    size = len;
-
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
       g.item_count++;
-      list_formatted_read_scalar (type, tmp + size*elem, len);
+      list_formatted_read_scalar (type, tmp + size*elem, kind, size);
     }
 }
 
@@ -1862,12 +1853,15 @@ nml_read_obj (namelist_info * nl, index_type offset)
 
     case GFC_DTYPE_INTEGER:
     case GFC_DTYPE_LOGICAL:
-    case GFC_DTYPE_REAL:
       dlen = len;
       break;
 
+    case GFC_DTYPE_REAL:
+      dlen = size_from_real_kind (len);
+      break;
+
     case GFC_DTYPE_COMPLEX:
-      dlen = 2* len;
+      dlen = size_from_complex_kind (len);
       break;
 
     case GFC_DTYPE_CHARACTER:
@@ -1927,7 +1921,7 @@ nml_read_obj (namelist_info * nl, index_type offset)
               break;
 
 	  case GFC_DTYPE_COMPLEX:
-              read_complex (len);
+              read_complex (len, dlen);
               break;
 
 	  case GFC_DTYPE_DERIVED:

libgfortran/io/size_from_kind.c

+/* Copyright (C) 2005 Free Software Foundation, Inc.
+   Contributed by Janne Blomqvist
+
+This file is part of the GNU Fortran 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file.  (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA.  */
+
+
+/* This file contains utility functions for determining the size of a
+   variable given its kind. */
+
+#include "io.h"
+
+size_t
+size_from_real_kind (int kind)
+{
+  switch (kind)
+    {
+#ifdef HAVE_GFC_REAL_4
+    case 4:
+      return sizeof (GFC_REAL_4);
+#endif
+#ifdef HAVE_GFC_REAL_8
+    case 8:
+      return sizeof (GFC_REAL_8);
+#endif
+#ifdef HAVE_GFC_REAL_10
+    case 10:
+      return sizeof (GFC_REAL_10);
+#endif
+#ifdef HAVE_GFC_REAL_16
+    case 16:
+      return sizeof (GFC_REAL_16);
+#endif
+    default:
+      return kind;
+    }
+}
+
+
+size_t
+size_from_complex_kind (int kind)
+{
+  switch (kind)
+    {
+#ifdef HAVE_GFC_COMPLEX_4
+    case 4:
+      return sizeof (GFC_COMPLEX_4);
+#endif
+#ifdef HAVE_GFC_COMPLEX_8
+    case 8:
+      return sizeof (GFC_COMPLEX_8);
+#endif
+#ifdef HAVE_GFC_COMPLEX_10
+    case 10:
+      return sizeof (GFC_COMPLEX_10);
+#endif
+#ifdef HAVE_GFC_COMPLEX_16
+    case 16:
+      return sizeof (GFC_COMPLEX_16);
+#endif
+    default:
+      return 2 * kind;
+    }
+}
+

libgfortran/io/transfer.c

@@ -78,7 +78,7 @@ export_proto(transfer_character);
 extern void transfer_complex (void *, int);
 export_proto(transfer_complex);
 
-extern void transfer_array (gfc_array_char *, gfc_charlen_type);
+extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
 export_proto(transfer_array);
 
 gfc_unit *current_unit = NULL;
@@ -104,7 +104,7 @@ static const st_option advance_opt[] = {
 };
 
 
-static void (*transfer) (bt, void *, int, size_t);
+static void (*transfer) (bt, void *, int, size_t, size_t);
 
 
 typedef enum
@@ -394,36 +394,26 @@ write_block_direct (void * buf, size_t * nbytes)
 /* Master function for unformatted reads.  */
 
 static void
-unformatted_read (bt type, void *dest, int length, size_t nelems)
+unformatted_read (bt type __attribute__((unused)), void *dest,
+                 int kind __attribute__((unused)),
+                 size_t size, size_t nelems)
 {
-  size_t len;
+  size *= nelems;
 
-  len = length * nelems;
-
-  /* Transfer functions get passed the kind of the entity, so we have
-     to fix this for COMPLEX data which are twice the size of their
-     kind.  */
-  if (type == BT_COMPLEX)
-    len *= 2;
-
-  read_block_direct (dest, &len);
+  read_block_direct (dest, &size);
 }
 
 
 /* Master function for unformatted writes.  */
 
 static void
-unformatted_write (bt type, void *source, int length, size_t nelems)
+unformatted_write (bt type __attribute__((unused)), void *source,
+                  int kind __attribute__((unused)),
+                  size_t size, size_t nelems)
 {
-  size_t len;
-
-  len = length * nelems;
+  size *= nelems;
 
-  /* Correction for kind vs. length as in unformatted_read.  */
-  if (type == BT_COMPLEX)
-    len *= 2;
-
-  write_block_direct (source, &len);
+  write_block_direct (source, &size);
 }
 
 
@@ -518,7 +508,7 @@ require_type (bt expected, bt actual, fnode * f)
    of the next element, then comes back here to process it.  */
 
 static void
-formatted_transfer_scalar (bt type, void *p, int len)
+formatted_transfer_scalar (bt type, void *p, int len, size_t size)
 {
   int pos, bytes_used;
   fnode *f;
@@ -530,7 +520,10 @@ formatted_transfer_scalar (bt type, void *p, int len)
 
   n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
   if (type == BT_COMPLEX)
-    type = BT_REAL;
+    {
+      type = BT_REAL;
+      size /= 2;
+    }
 
   /* If there's an EOR condition, we simulate finalizing the transfer
      by doing nothing.  */
@@ -893,7 +886,7 @@ formatted_transfer_scalar (bt type, void *p, int len)
       if ((consume_data_flag > 0) && (n > 0))
       {
 	n--;
-	p = ((char *) p) + len;
+	p = ((char *) p) + size;
       }
 
       if (g.mode == READING)
@@ -914,24 +907,18 @@ formatted_transfer_scalar (bt type, void *p, int len)
 }
 
 static void
-formatted_transfer (bt type, void *p, int len, size_t nelems)
+formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
 {
   size_t elem;
-  int  size;
   char *tmp;
 
   tmp = (char *) p;
 
-  if (type == BT_COMPLEX)
-    size = 2 * len;
-  else
-    size = len;
-
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
       g.item_count++;
-      formatted_transfer_scalar (type, tmp + size*elem, len);
+      formatted_transfer_scalar (type, tmp + size*elem, kind, size);
     }
 }
 
@@ -946,16 +933,18 @@ transfer_integer (void *p, int kind)
 {
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_INTEGER, p, kind, 1);
+  transfer (BT_INTEGER, p, kind, kind, 1);
 }
 
 
 void
 transfer_real (void *p, int kind)
 {
+  size_t size;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_REAL, p, kind, 1);
+  size = size_from_real_kind (kind);
+  transfer (BT_REAL, p, kind, size, 1);
 }
 
 
@@ -964,7 +953,7 @@ transfer_logical (void *p, int kind)
 {
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_LOGICAL, p, kind, 1);
+  transfer (BT_LOGICAL, p, kind, kind, 1);
 }
 
 
@@ -973,26 +962,31 @@ transfer_character (void *p, int len)
 {
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_CHARACTER, p, len, 1);
+  /* Currently we support only 1 byte chars, and the library is a bit
+     confused of character kind vs. length, so we kludge it by setting
+     kind = length.  */
+  transfer (BT_CHARACTER, p, len, len, 1);
 }
 
 
 void
 transfer_complex (void *p, int kind)
 {
+  size_t size;
   if (ioparm.library_return != LIBRARY_OK)
     return;
-  transfer (BT_COMPLEX, p, kind, 1);
+  size = size_from_complex_kind (kind);
+  transfer (BT_COMPLEX, p, kind, size, 1);
 }
 
 
 void
-transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
+transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
 {
   index_type count[GFC_MAX_DIMENSIONS];
   index_type extent[GFC_MAX_DIMENSIONS];
   index_type stride[GFC_MAX_DIMENSIONS];
-  index_type stride0, rank, size, type, n, kind;
+  index_type stride0, rank, size, type, n;
   size_t tsize;
   char *data;
   bt iotype;
@@ -1002,7 +996,6 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
 
   type = GFC_DESCRIPTOR_TYPE (desc);
   size = GFC_DESCRIPTOR_SIZE (desc);
-  kind = size;
 
   /* FIXME: What a kludge: Array descriptors and the IO library use
      different enums for types.  */
@@ -1022,7 +1015,6 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
       break;
     case GFC_DTYPE_COMPLEX:
       iotype = BT_COMPLEX;
-      kind /= 2;
       break;
     case GFC_DTYPE_CHARACTER:
       iotype = BT_CHARACTER;
@@ -1070,7 +1062,7 @@ transfer_array (gfc_array_char *desc, gfc_charlen_type charlen)
 
   while (data)
     {
-      transfer (iotype, data, kind, tsize);
+      transfer (iotype, data, kind, size, tsize);
       data += stride0 * size * tsize;
       count[0] += tsize;
       n = 0;
@@ -1450,7 +1442,7 @@ data_transfer_init (int read_flag)
   /* 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, 1);
+    formatted_transfer (0, NULL, 0, 0, 1);
 }
 
 /* Initialize an array_loop_spec given the array descriptor.  The function
@@ -1862,16 +1854,13 @@ finalize_transfer (void)
    data transfer, it just updates the length counter.  */
 
 static void
-iolength_transfer (bt type, void *dest __attribute__ ((unused)),
-		   int len, size_t nelems)
+iolength_transfer (bt type __attribute__((unused)), 
+		   void *dest __attribute__ ((unused)),
+		   int kind __attribute__((unused)), 
+		   size_t size, size_t nelems)
 {
   if (ioparm.iolength != NULL)
-    {
-      if (type == BT_COMPLEX)
-	*ioparm.iolength += 2 * len * nelems;
-      else
-	*ioparm.iolength += len * nelems;
-    }
+    *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
 }
 
 

libgfortran/io/write.c

@@ -1394,15 +1394,15 @@ write_real (const char *source, int length)
 
 
 static void
-write_complex (const char *source, int len)
+write_complex (const char *source, int kind, size_t size)
 {
   if (write_char ('('))
     return;
-  write_real (source, len);
+  write_real (source, kind);
 
   if (write_char (','))
     return;
-  write_real (source + len, len);
+  write_real (source + size / 2, kind);
 
   write_char (')');
 }
@@ -1428,7 +1428,7 @@ write_separator (void)
    with strings.  */
 
 static void
-list_formatted_write_scalar (bt type, void *p, int len)
+list_formatted_write_scalar (bt type, void *p, int kind, size_t size)
 {
   static int char_flag;
 
@@ -1451,19 +1451,19 @@ list_formatted_write_scalar (bt type, void *p, int len)
   switch (type)
     {
     case BT_INTEGER:
-      write_integer (p, len);
+      write_integer (p, kind);
       break;
     case BT_LOGICAL:
-      write_logical (p, len);
+      write_logical (p, kind);
       break;
     case BT_CHARACTER:
-      write_character (p, len);
+      write_character (p, kind);
       break;
     case BT_REAL:
-      write_real (p, len);
+      write_real (p, kind);
       break;
     case BT_COMPLEX:
-      write_complex (p, len);
+      write_complex (p, kind, size);
       break;
     default:
       internal_error ("list_formatted_write(): Bad type");
@@ -1474,24 +1474,18 @@ list_formatted_write_scalar (bt type, void *p, int len)
 
 
 void
-list_formatted_write (bt type, void *p, int len, size_t nelems)
+list_formatted_write (bt type, void *p, int kind, size_t size, size_t nelems)
 {
   size_t elem;
-  int size;
   char *tmp;
 
   tmp = (char *) p;
 
-  if (type == BT_COMPLEX)
-    size = 2 * len;
-  else
-    size = len;
-
   /* Big loop over all the elements.  */
   for (elem = 0; elem < nelems; elem++)
     {
       g.item_count++;
-      list_formatted_write_scalar (type, tmp + size*elem, len);
+      list_formatted_write_scalar (type, tmp + size*elem, kind, size);
     }
 }
 
@@ -1573,11 +1567,26 @@ nml_write_obj (namelist_info * obj, index_type offset,
   num = 1;
 
   len = obj->len;
-  obj_size = len;
-  if (obj->type == GFC_DTYPE_COMPLEX)
-    obj_size = 2*len;
-  if (obj->type == GFC_DTYPE_CHARACTER)
-    obj_size = obj->string_length;
+
+  switch (obj->type)
+    {
+
+    case GFC_DTYPE_REAL:
+      obj_size = size_from_real_kind (len);
+      break;
+
+    case GFC_DTYPE_COMPLEX:
+      obj_size = size_from_complex_kind (len);
+      break;
+
+    case GFC_DTYPE_CHARACTER:
+      obj_size = obj->string_length;
+      break;
+
+    default:
+      obj_size = len;      
+    }
+
   if (obj->var_rank)
     obj_size = obj->size;
 
@@ -1654,7 +1663,7 @@ nml_write_obj (namelist_info * obj, index_type offset,
 	    case GFC_DTYPE_COMPLEX:
 	      no_leading_blank = 0;
 	      num++;
-              write_complex (p, len);
+              write_complex (p, len, obj_size);
               break;
 
 	    case GFC_DTYPE_DERIVED: