1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist output contibuted by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
37 #include "libgfortran.h"
41 #define star_fill(p, n) memset(p, '*', n)
45 { SIGN_NONE
, SIGN_MINUS
, SIGN_PLUS
}
49 static int no_leading_blank
= 0 ;
52 write_a (fnode
* f
, const char *source
, int len
)
57 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
59 p
= write_block (wlen
);
64 memcpy (p
, source
, wlen
);
67 memset (p
, ' ', wlen
- len
);
68 memcpy (p
+ wlen
- len
, source
, len
);
73 extract_int (const void *p
, int len
)
83 i
= *((const int8_t *) p
);
86 i
= *((const int16_t *) p
);
89 i
= *((const int32_t *) p
);
92 i
= *((const int64_t *) p
);
95 internal_error ("bad integer kind");
102 extract_real (const void *p
, int len
)
108 i
= *((const float *) p
);
111 i
= *((const double *) p
);
114 internal_error ("bad real kind");
121 /* Given a flag that indicate if a value is negative or not, return a
122 sign_t that gives the sign that we need to produce. */
125 calculate_sign (int negative_flag
)
127 sign_t s
= SIGN_NONE
;
132 switch (g
.sign_status
)
141 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
149 /* Returns the value of 10**d. */
152 calculate_exp (int d
)
157 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
160 r
= (d
>= 0) ? r
: 1.0 / r
;
166 /* Generate corresponding I/O format for FMT_G output.
167 The rules to translate FMT_G to FMT_E or FMT_F from DEC fortran
168 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
170 Data Magnitude Equivalent Conversion
171 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
172 m = 0 F(w-n).(d-1), n' '
173 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
174 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
175 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
176 ................ ..........
177 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
178 m >= 10**d-0.5 Ew.d[Ee]
180 notes: for Gw.d , n' ' means 4 blanks
181 for Gw.dEe, n' ' means e+2 blanks */
184 calculate_G_format (fnode
*f
, double value
, int len
, int *num_blank
)
194 newf
= get_mem (sizeof (fnode
));
196 /* Absolute value. */
197 m
= (value
> 0.0) ? value
: -value
;
199 /* In case of the two data magnitude ranges,
200 generate E editing, Ew.d[Ee]. */
201 exp_d
= calculate_exp (d
);
202 if ((m
> 0.0 && m
< 0.1 - 0.05 / (double) exp_d
)
203 || (m
>= (double) exp_d
- 0.5 ))
205 newf
->format
= FMT_E
;
213 /* Use binary search to find the data magnitude range. */
223 mid
= (low
+ high
) / 2;
225 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
226 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
231 if (ubound
== lbound
+ 1)
238 if (ubound
== lbound
+ 1)
249 /* Pad with blanks where the exponent would be. */
255 /* Generate the F editing. F(w-n).(-(mid-d-1)), n' '. */
256 newf
->format
= FMT_F
;
257 newf
->u
.real
.w
= f
->u
.real
.w
- *num_blank
;
261 newf
->u
.real
.d
= d
- 1;
263 newf
->u
.real
.d
= - (mid
- d
- 1);
265 /* For F editing, the scale factor is ignored. */
271 /* Output a real number according to its format which is FMT_G free. */
274 output_float (fnode
*f
, double value
, int len
)
276 /* This must be large enough to accurately hold any value. */
287 /* Number of digits before the decimal point. */
289 /* Number of zeros after the decimal point. */
291 /* Number of digits after the decimal point. */
293 /* Number of zeros after the decimal point, whatever the precision. */
307 /* We should always know the field width and precision. */
309 internal_error ("Unspecified precision");
311 /* Use sprintf to print the number in the format +D.DDDDe+ddd
312 For an N digit exponent, this gives us (32-6)-N digits after the
313 decimal point, plus another one before the decimal point. */
314 sign
= calculate_sign (value
< 0.0);
318 /* Printf always prints at least two exponent digits. */
323 edigits
= 1 + (int) log10 (fabs(log10 (value
)));
328 if (ft
== FMT_F
|| ft
== FMT_EN
329 || ((ft
== FMT_D
|| ft
== FMT_E
) && g
.scale_factor
!= 0))
331 /* Always convert at full precision to avoid double rounding. */
332 ndigits
= 27 - edigits
;
336 /* We know the number of digits, so can let printf do the rounding
342 if (ndigits
> 27 - edigits
)
343 ndigits
= 27 - edigits
;
346 sprintf (buffer
, "%+-#31.*e", ndigits
- 1, value
);
348 /* Check the resulting string has punctuation in the correct places. */
349 if (buffer
[2] != '.' || buffer
[ndigits
+ 2] != 'e')
350 internal_error ("printf is broken");
352 /* Read the exponent back in. */
353 e
= atoi (&buffer
[ndigits
+ 3]) + 1;
355 /* Make sure zero comes out as 0.0e0. */
359 /* Normalize the fractional component. */
360 buffer
[2] = buffer
[1];
363 /* Figure out where to place the decimal point. */
367 nbefore
= e
+ g
.scale_factor
;
400 nafter
= (d
- i
) + 1;
416 /* The exponent must be a multiple of three, with 1-3 digits before
417 the decimal point. */
426 nbefore
= 3 - nbefore
;
445 /* Should never happen. */
446 internal_error ("Unexpected format token");
449 /* Round the value. */
450 if (nbefore
+ nafter
== 0)
453 if (nzero_real
== d
&& digits
[0] >= '5')
455 /* We rounded to zero but shouldn't have */
462 else if (nbefore
+ nafter
< ndigits
)
464 ndigits
= nbefore
+ nafter
;
466 if (digits
[i
] >= '5')
468 /* Propagate the carry. */
469 for (i
--; i
>= 0; i
--)
471 if (digits
[i
] != '9')
481 /* The carry overflowed. Fortunately we have some spare space
482 at the start of the buffer. We may discard some digits, but
483 this is ok because we already know they are zero. */
496 else if (ft
== FMT_EN
)
511 /* Calculate the format of the exponent field. */
515 for (i
= abs (e
); i
>= 10; i
/= 10)
520 /* Width not specified. Must be no more than 3 digits. */
521 if (e
> 999 || e
< -999)
526 if (e
> 99 || e
< -99)
532 /* Exponent width specified, check it is wide enough. */
533 if (edigits
> f
->u
.real
.e
)
536 edigits
= f
->u
.real
.e
+ 2;
542 /* Pick a field size if none was specified. */
544 w
= nbefore
+ nzero
+ nafter
+ (sign
!= SIGN_NONE
? 2 : 1);
546 /* Create the ouput buffer. */
547 out
= write_block (w
);
551 /* Zero values always output as positive, even if the value was negative
553 for (i
= 0; i
< ndigits
; i
++)
555 if (digits
[i
] != '0')
559 sign
= calculate_sign (0);
561 /* Work out how much padding is needed. */
562 nblanks
= w
- (nbefore
+ nzero
+ nafter
+ edigits
+ 1);
563 if (sign
!= SIGN_NONE
)
566 /* Check the value fits in the specified field width. */
567 if (nblanks
< 0 || edigits
== -1)
573 /* See if we have space for a zero before the decimal point. */
574 if (nbefore
== 0 && nblanks
> 0)
582 /* Padd to full field width. */
585 if ( ( nblanks
> 0 ) && !no_leading_blank
)
587 memset (out
, ' ', nblanks
);
591 /* Output the initial sign (if any). */
592 if (sign
== SIGN_PLUS
)
594 else if (sign
== SIGN_MINUS
)
597 /* Output an optional leading zero. */
601 /* Output the part before the decimal point, padding with zeros. */
604 if (nbefore
> ndigits
)
609 memcpy (out
, digits
, i
);
617 /* Output the decimal point. */
620 /* Output leading zeros after the decimal point. */
623 for (i
= 0; i
< nzero
; i
++)
627 /* Output digits after the decimal point, padding with zeros. */
630 if (nafter
> ndigits
)
635 memcpy (out
, digits
, i
);
644 /* Output the exponent. */
653 snprintf (buffer
, 32, "%+0*d", edigits
, e
);
655 sprintf (buffer
, "%+0*d", edigits
, e
);
657 memcpy (out
, buffer
, edigits
);
660 if ( no_leading_blank
)
663 memset( out
, ' ' , nblanks
);
664 no_leading_blank
= 0;
670 write_l (fnode
* f
, char *source
, int len
)
675 p
= write_block (f
->u
.w
);
679 memset (p
, ' ', f
->u
.w
- 1);
680 n
= extract_int (source
, len
);
681 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
684 /* Output a real number according to its format. */
687 write_float (fnode
*f
, const char *source
, int len
)
690 int nb
=0, res
, save_scale_factor
;
694 n
= extract_real (source
, len
);
696 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
702 p
= write_block (nb
);
719 memcpy(p
+ nb
- 8, "Infinity", 8);
721 memcpy(p
+ nb
- 3, "Inf", 3);
722 if (nb
< 8 && nb
> 3)
728 memcpy(p
+ nb
- 3, "NaN", 3);
733 if (f
->format
!= FMT_G
)
735 output_float (f
, n
, len
);
739 save_scale_factor
= g
.scale_factor
;
740 f2
= calculate_G_format(f
, n
, len
, &nb
);
741 output_float (f2
, n
, len
);
742 g
.scale_factor
= save_scale_factor
;
748 p
= write_block (nb
);
756 write_int (fnode
*f
, const char *source
, int len
, char *(*conv
) (uint64_t))
760 int w
, m
, digits
, nzero
, nblank
;
766 n
= extract_int (source
, len
);
770 if (m
== 0 && n
== 0)
794 /* Select a width if none was specified. The idea here is to always
798 w
= ((digits
< m
) ? m
: digits
);
808 /* See if things will work. */
810 nblank
= w
- (nzero
+ digits
);
819 if (!no_leading_blank
)
821 memset (p
, ' ', nblank
);
823 memset (p
, '0', nzero
);
825 memcpy (p
, q
, digits
);
829 memset (p
, '0', nzero
);
831 memcpy (p
, q
, digits
);
833 memset (p
, ' ', nblank
);
834 no_leading_blank
= 0;
842 write_decimal (fnode
*f
, const char *source
, int len
, char *(*conv
) (int64_t))
845 int w
, m
, digits
, nsign
, nzero
, nblank
;
852 n
= extract_int (source
, len
);
856 if (m
== 0 && n
== 0)
869 sign
= calculate_sign (n
< 0);
873 nsign
= sign
== SIGN_NONE
? 0 : 1;
878 /* Select a width if none was specified. The idea here is to always
882 w
= ((digits
< m
) ? m
: digits
) + nsign
;
892 /* See if things will work. */
894 nblank
= w
- (nsign
+ nzero
+ digits
);
902 memset (p
, ' ', nblank
);
917 memset (p
, '0', nzero
);
920 memcpy (p
, q
, digits
);
927 /* Convert unsigned octal to ascii. */
941 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
955 /* Convert unsigned binary to ascii. */
969 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
974 *p
-- = '0' + (n
& 1);
983 write_i (fnode
* f
, const char *p
, int len
)
985 write_decimal (f
, p
, len
, (void *) gfc_itoa
);
990 write_b (fnode
* f
, const char *p
, int len
)
992 write_int (f
, p
, len
, btoa
);
997 write_o (fnode
* f
, const char *p
, int len
)
999 write_int (f
, p
, len
, otoa
);
1003 write_z (fnode
* f
, const char *p
, int len
)
1005 write_int (f
, p
, len
, xtoa
);
1010 write_d (fnode
*f
, const char *p
, int len
)
1012 write_float (f
, p
, len
);
1017 write_e (fnode
*f
, const char *p
, int len
)
1019 write_float (f
, p
, len
);
1024 write_f (fnode
*f
, const char *p
, int len
)
1026 write_float (f
, p
, len
);
1031 write_en (fnode
*f
, const char *p
, int len
)
1033 write_float (f
, p
, len
);
1038 write_es (fnode
*f
, const char *p
, int len
)
1040 write_float (f
, p
, len
);
1044 /* Take care of the X/TR descriptor. */
1051 p
= write_block (f
->u
.n
);
1055 memset (p
, ' ', f
->u
.n
);
1059 /* List-directed writing. */
1062 /* Write a single character to the output. Returns nonzero if
1063 something goes wrong. */
1070 p
= write_block (1);
1080 /* Write a list-directed logical value. */
1083 write_logical (const char *source
, int length
)
1085 write_char (extract_int (source
, length
) ? 'T' : 'F');
1089 /* Write a list-directed integer value. */
1092 write_integer (const char *source
, int length
)
1099 q
= gfc_itoa (extract_int (source
, length
));
1124 digits
= strlen (q
);
1128 p
= write_block (width
) ;
1129 if (no_leading_blank
)
1131 memcpy (p
, q
, digits
);
1132 memset(p
+ digits
,' ', width
- digits
) ;
1136 memset(p
,' ', width
- digits
) ;
1137 memcpy (p
+ width
- digits
, q
, digits
);
1142 /* Write a list-directed string. We have to worry about delimiting
1143 the strings if the file has been opened in that mode. */
1146 write_character (const char *source
, int length
)
1151 switch (current_unit
->flags
.delim
)
1153 case DELIM_APOSTROPHE
:
1170 for (i
= 0; i
< length
; i
++)
1175 p
= write_block (length
+ extra
);
1180 memcpy (p
, source
, length
);
1185 for (i
= 0; i
< length
; i
++)
1197 /* Output a real number with default format.
1198 This is 1PG14.7E2 for REAL(4) and 1PG23.15E3 for REAL(8). */
1201 write_real (const char *source
, int length
)
1204 int org_scale
= g
.scale_factor
;
1219 write_float (&f
, source
, length
);
1220 g
.scale_factor
= org_scale
;
1225 write_complex (const char *source
, int len
)
1227 if (write_char ('('))
1229 write_real (source
, len
);
1231 if (write_char (','))
1233 write_real (source
+ len
, len
);
1239 /* Write the separator between items. */
1242 write_separator (void)
1246 p
= write_block (options
.separator_len
);
1250 memcpy (p
, options
.separator
, options
.separator_len
);
1254 /* Write an item with list formatting.
1255 TODO: handle skipping to the next record correctly, particularly
1259 list_formatted_write (bt type
, void *p
, int len
)
1261 static int char_flag
;
1263 if (current_unit
== NULL
)
1274 if (type
!= BT_CHARACTER
|| !char_flag
||
1275 current_unit
->flags
.delim
!= DELIM_NONE
)
1282 write_integer (p
, len
);
1285 write_logical (p
, len
);
1288 write_character (p
, len
);
1291 write_real (p
, len
);
1294 write_complex (p
, len
);
1297 internal_error ("list_formatted_write(): Bad type");
1300 char_flag
= (type
== BT_CHARACTER
);
1305 nml_write_obj writes a namelist object to the output stream. It is called
1306 recursively for derived type components:
1307 obj = is the namelist_info for the current object.
1308 offset = the offset relative to the address held by the object for
1309 derived type arrays.
1310 base = is the namelist_info of the derived type, when obj is a
1312 base_name = the full name for a derived type, including qualifiers
1314 The returned value is a pointer to the object beyond the last one
1315 accessed, including nested derived types. Notice that the namelist is
1316 a linear linked list of objects, including derived types and their
1317 components. A tree, of sorts, is implied by the compound names of
1318 the derived type components and this is how this function recurses through
1321 /* A generous estimate of the number of characters needed to print
1322 repeat counts and indices, including commas, asterices and brackets. */
1324 #define NML_DIGITS 20
1326 /* Stores the delimiter to be used for character objects. */
1328 static char * nml_delim
;
1330 static namelist_info
*
1331 nml_write_obj (namelist_info
* obj
, index_type offset
,
1332 namelist_info
* base
, char * base_name
)
1338 index_type obj_size
;
1342 index_type elem_ctr
;
1343 index_type obj_name_len
;
1348 char rep_buff
[NML_DIGITS
];
1349 namelist_info
* cmp
;
1350 namelist_info
* retval
= obj
->next
;
1352 /* Write namelist variable names in upper case. If a derived type,
1353 nothing is output. If a component, base and base_name are set. */
1355 if (obj
->type
!= GFC_DTYPE_DERIVED
)
1357 write_character ("\n ", 2);
1361 len
=strlen (base
->var_name
);
1362 for (dim_i
= 0; dim_i
< strlen (base_name
); dim_i
++)
1364 cup
= toupper (base_name
[dim_i
]);
1365 write_character (&cup
, 1);
1368 for (dim_i
=len
; dim_i
< strlen (obj
->var_name
); dim_i
++)
1370 cup
= toupper (obj
->var_name
[dim_i
]);
1371 write_character (&cup
, 1);
1373 write_character ("=", 1);
1376 /* Counts the number of data output on a line, including names. */
1382 if (obj
->type
== GFC_DTYPE_COMPLEX
)
1384 if (obj
->type
== GFC_DTYPE_CHARACTER
)
1385 obj_size
= obj
->string_length
;
1387 obj_size
= obj
->size
;
1389 /* Set the index vector and count the number of elements. */
1392 for (dim_i
=0; dim_i
< obj
->var_rank
; dim_i
++)
1394 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1395 nelem
= nelem
* (obj
->dim
[dim_i
].ubound
+ 1 - obj
->dim
[dim_i
].lbound
);
1398 /* Main loop to output the data held in the object. */
1401 for (elem_ctr
= 0; elem_ctr
< nelem
; elem_ctr
++)
1404 /* Build the pointer to the data value. The offset is passed by
1405 recursive calls to this function for arrays of derived types.
1406 Is NULL otherwise. */
1408 p
= (void *)(obj
->mem_pos
+ elem_ctr
* obj_size
);
1411 /* Check for repeat counts of intrinsic types. */
1413 if ((elem_ctr
< (nelem
- 1)) &&
1414 (obj
->type
!= GFC_DTYPE_DERIVED
) &&
1415 !memcmp (p
, (void*)(p
+ obj_size
), obj_size
))
1420 /* Execute a repeated output. Note the flag no_leading_blank that
1421 is used in the functions used to output the intrinsic types. */
1427 st_sprintf(rep_buff
, " %d*", rep_ctr
);
1428 write_character (rep_buff
, strlen (rep_buff
));
1429 no_leading_blank
= 1;
1433 /* Output the data, if an intrinsic type, or recurse into this
1434 routine to treat derived types. */
1439 case GFC_DTYPE_INTEGER
:
1440 write_integer (p
, len
);
1443 case GFC_DTYPE_LOGICAL
:
1444 write_logical (p
, len
);
1447 case GFC_DTYPE_CHARACTER
:
1449 write_character (nml_delim
, 1);
1450 write_character (p
, obj
->string_length
);
1452 write_character (nml_delim
, 1);
1455 case GFC_DTYPE_REAL
:
1456 write_real (p
, len
);
1459 case GFC_DTYPE_COMPLEX
:
1460 no_leading_blank
= 0;
1462 write_complex (p
, len
);
1465 case GFC_DTYPE_DERIVED
:
1467 /* To treat a derived type, we need to build two strings:
1468 ext_name = the name, including qualifiers that prepends
1469 component names in the output - passed to
1471 obj_name = the derived type name with no qualifiers but %
1472 appended. This is used to identify the
1475 /* First ext_name => get length of all possible components */
1477 ext_name
= (char*)get_mem ( (base_name
? strlen (base_name
) : 0)
1478 + (base
? strlen (base
->var_name
) : 0)
1479 + strlen (obj
->var_name
)
1480 + obj
->var_rank
* NML_DIGITS
);
1482 strcpy(ext_name
, base_name
? base_name
: "");
1483 clen
= base
? strlen (base
->var_name
) : 0;
1484 strcat (ext_name
, obj
->var_name
+ clen
);
1486 /* Append the qualifier. */
1488 for (dim_i
= 0; dim_i
< obj
->var_rank
; dim_i
++)
1490 strcat (ext_name
, dim_i
? "" : "(");
1491 clen
= strlen (ext_name
);
1492 st_sprintf (ext_name
+ clen
, "%d", obj
->ls
[dim_i
].idx
);
1493 strcat (ext_name
, (dim_i
== obj
->var_rank
- 1) ? ")" : ",");
1498 obj_name_len
= strlen (obj
->var_name
) + 1;
1499 obj_name
= get_mem (obj_name_len
+1);
1500 strcpy (obj_name
, obj
->var_name
);
1501 strcat (obj_name
, "%");
1503 /* Now loop over the components. Update the component pointer
1504 with the return value from nml_write_obj => this loop jumps
1505 past nested derived types. */
1507 for (cmp
= obj
->next
;
1508 cmp
&& !strncmp (cmp
->var_name
, obj_name
, obj_name_len
);
1511 retval
= nml_write_obj (cmp
, (index_type
)(p
- obj
->mem_pos
),
1515 free_mem (obj_name
);
1516 free_mem (ext_name
);
1520 internal_error ("Bad type for namelist write");
1523 /* Reset the leading blank suppression, write a comma and, if 5
1524 values have been output, write a newline and advance to column
1525 2. Reset the repeat counter. */
1527 no_leading_blank
= 0;
1528 write_character (",", 1);
1532 write_character ("\n ", 2);
1537 /* Cycle through and increment the index vector. */
1542 for (dim_i
= 0; nml_carry
&& (dim_i
< obj
->var_rank
); dim_i
++)
1544 obj
->ls
[dim_i
].idx
+= nml_carry
;
1546 if (obj
->ls
[dim_i
].idx
> (ssize_t
)obj
->dim
[dim_i
].ubound
)
1548 obj
->ls
[dim_i
].idx
= obj
->dim
[dim_i
].lbound
;
1554 /* Return a pointer beyond the furthest object accessed. */
1559 /* This is the entry function for namelist writes. It outputs the name
1560 of the namelist and iterates through the namelist by calls to
1561 nml_write_obj. The call below has dummys in the arguments used in
1562 the treatment of derived types. */
1565 namelist_write (void)
1567 namelist_info
* t1
, *t2
, *dummy
= NULL
;
1569 index_type dummy_offset
= 0;
1571 char * dummy_name
= NULL
;
1572 unit_delim tmp_delim
;
1574 /* Set the delimiter for namelist output. */
1576 tmp_delim
= current_unit
->flags
.delim
;
1577 current_unit
->flags
.delim
= DELIM_NONE
;
1584 case (DELIM_APOSTROPHE
):
1592 write_character ("&",1);
1594 /* Write namelist name in upper case - f95 std. */
1596 for (i
= 0 ;i
< ioparm
.namelist_name_len
;i
++ )
1598 c
= toupper (ioparm
.namelist_name
[i
]);
1599 write_character (&c
,1);
1608 t1
= nml_write_obj (t2
, dummy_offset
, dummy
, dummy_name
);
1611 write_character (" /\n", 4);
1613 /* Recover the original delimiter. */
1615 current_unit
->flags
.delim
= tmp_delim
;