/*

  Copyright (C) 2000, 2001, Silicon Graphics, Inc.  All Rights Reserved.

   Path64 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 version 2.1

   Path64 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 Path64; see the file COPYING.  If not, write to the Free
   Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
   02110-1301, USA.

   Special thanks goes to SGI for their continued support to open source

*/



#pragma ident "@(#) libf/fio/lwrite.c	92.5	06/23/99 16:08:16"
#include <ctype.h>
#include <stdlib.h>
#include <string.h>
#include <fortran.h>
#include <cray/fmtconv.h>
#include <cray/nassert.h>
#ifdef	_CRAYT3D
#include <cray/mppsdd.h>
#define	MAXSH	512
#else
#define	MAXSH	1
#endif
#include "fio.h"
#include "fmt.h"
#include "f90io.h"
#include "lio.h"

short	_old_list_out_repcounts		= 0;
short	_90_char_nonchar_delim_blanks	= 1;
short	_blank_at_start_of_empty_rec	= 1;

extern oc_func	*_oldotab[DVTYPE_NTYPES];
extern oc_func	_sd2udee;

/*
 *	Forward reference
 */
int
_beautify(ftype_t type, long *plain, long *limit, long *pretty, short isf90);

int
_find_dupcnt(void *ptr, long count, long stride, int elsize, short ischar);

int
_write_delimited_char(FIOSPTR css, unit *cup, char *sptr, int len, long dchar);

/*
 *	COMPEQ compares the current output item with a saved output item.
 *	Evaluates to 1 if equal, 0 if not equal.
 */
#define COMPEQ(css, cptr, newtype, newelsize) ( \
	(css->u.fmt.u.le.type == newtype) && \
	(css->u.fmt.u.le.elsize == newelsize) && \
	(css->u.fmt.u.le.elsize > sizeof(css->u.fmt.u.le.u.value) ? \
		(memcmp(css->u.fmt.u.le.u.copy, cptr, newelsize) == 0) : \
		(memcmp(css->u.fmt.u.le.u.value, cptr, newelsize) == 0)))

#define WINT1	4
#define WINT2	6
#define WINT4	11
#define WDIG4	7
#define WDIG8	16
#define WDIG16	30
#define WRL4	15
#define WRL8	24
#define WRL16	41

/*
 *	_ld_write 
 *		List-directed write
 *
 *	Return Value:
 *		 0	normal return
 *		>0	error return
 */

int
_ld_write(
	FIOSPTR		css,	/* Pointer to current state		*/
	unit		*cup,	/* Unit pointer				*/
	void		*dptr,	/* Pointer to data			*/
	type_packet	*tip,	/* Type information packet		*/
	int		_Unused)/* Unused by this routine		*/
{
	register short	blanks;	/* Number of leading blanks		*/
	register short	ischar;	/* Is variable type CHARACTER?		*/
	register short	ndchar;	/* Local copy of css->u.fmt.u.le.ndchar	*/
	register ftype_t type;	/* Fortran data type			*/
	register int	elsize;	/* Size of each data time (bytes)	*/
	register int	i;	/* Loop index				*/
	register int	realsz;	/* size in bytes of the real data item	*/
	register int	repcnt;	/* Local copy of css->u.fmt.u.le.repcnt	*/
	register int	tbsz;	/* Number of characters in tbuf		*/
	register long	count;	/* Number of data items			*/
	register long	delim;	/* Delimiter, else 0 if none		*/
	register long	vinc;	/* Virtual stride			*/
	long		tbuf[ITEMBUFSIZ];
	long		plain[ITEMBUFSIZ]; /* buffer for numeric output	*/
	long		*tptr;	/* Pointer to location in tbuf		*/
	char		*cptr;	/* Character pointer to datum		*/
	const long	zero = 0;
#ifdef	_CRAYT3D
	register short	shared;	/* Is variable shared?			*/
	register int	elwords;/* Number of words per item		*/
	register int	offset;	/* Offset from address in item units	*/
	register int	tcount;	/* Number of items to move		*/
	long		shrd[MAXSH];	/* Shared data copy buffer	*/
#endif

	/* Assertions */

	assert ( cup != NULL );
	assert ( css != NULL );
	assert ( tip != NULL );

	cptr	= (char *) dptr;

	type	= tip->type90;
	count	= tip->count;
	elsize	= tip->elsize;
	vinc	= tip->stride;

	ischar	= (type == DVTYPE_ASCII) ? 1 : 0;

/*
 *	The ldwinit field is set to 1 the first time _ld_write is called
 *	during any WRITE statement.
 */
	if (css->u.fmt.u.le.ldwinit) {
		css->u.fmt.u.le.item1	= 1;
		css->u.fmt.u.le.repcnt	= 0;
		css->u.fmt.u.le.ndchar	= 0;
		css->u.fmt.u.le.ldwinit	= 0;
	}

	repcnt	= css->u.fmt.u.le.repcnt;
	ndchar	= css->u.fmt.u.le.ndchar;

/*
 *	Figure out if character variables would be delimited by a quote or
 *	a character.
 */
	delim	= 0;

	if (cup->udelim != OS_NONE)
		delim	= ((cup->udelim == OS_QUOTE) ? DQUOTE : SQUOTE);
	else if (css->f_iostmt == T_WNL && !cup->uft90)
		delim	= SQUOTE;

	if (cup->ulinemax > cup->uldwsize || cup->uldwsize <= 1)
		RERROR(FEWRLONG);	/* Record too long */

	if (count > 0 || repcnt > 0 || _blank_at_start_of_empty_rec) {
		if (cup->ulinemax == 0) {	/* If line empty */
			*(cup->ulineptr++)	= BLANK;
			cup->ulinemax		= cup->ulinemax + 1;
		}				
	}

/*
 *	If count is zero, then _ld_write is being called to terminate the
 *	current list-directed write statement processing.
 */
	if (count == 0) {
		if (repcnt > 0)
			goto print_saved_value;
		else
			goto fin;
	}

/*
 *	Special processing for T3D CRAFT shared variables.
 */

#ifdef	_CRAYT3D
	if (_issddptr(dptr)) {
		offset	= 0;
		elwords	= elsize / sizeof(long);
		tcount	= count;
		vinc	= 1;	/* We now have a unit stride */
		shared	= 1;
	}
	else
		shared	= 0;

   do {
	if (shared) {

		/* Copy data into local array shrd, and write from there */

		count	= MIN(MAXSH / elwords, (tcount - offset));
		_cpyfrmsdd(dptr, shrd, count, elwords, tip->stride, offset);
		offset	= offset + count;
		cptr	= (char *) shrd;
	}
#endif

	/*
	 *	M A I N   L O O P
	 */

	while (count > 0) {	/* While more to write */
		register int	dupcnt;	/* Number of duplicate data items */
		long		width;	/* Conversion field width */
		long		mode;	/* Conversion mode flags */
		long		digits;	/* Number of digits */
		long		expon;	/* Conversion exponent */
		long		scale;	/* Conversion scale factor */
		long		*newp;	/* Pointer to end of numeric conversion */
		oc_func	*gcf;	/* Generic NOCV-type conversion func */

		/*
		 * If there is a saved output value, and a nondelimited
		 * character is being printed or old output style is selected
		 * or the current output item is not equal to the stored
		 * output item, or the assign option to skip the
		 * repeat count is present, then print the stored
		 * output item.
		 */

		if (repcnt > 0 && ( _old_list_out_repcounts ||
		    !COMPEQ(css, cptr, type, elsize) ||
		    (cup->ufrptcnt !=0))) {
			register int	prevlen;
			register ftype_t prevtyp;
			char		*prevptr;
print_saved_value:

			prevlen	= css->u.fmt.u.le.elsize;
			prevtyp	= css->u.fmt.u.le.type;

			if (prevlen <= sizeof(css->u.fmt.u.le.u.value))
				prevptr	= (char *) &css->u.fmt.u.le.u.value[0];
			else
				prevptr	= (char *) css->u.fmt.u.le.u.copy;

			tptr	= tbuf;
			blanks	= 0;

			/*
			 * Now we handle the printing of a value separator
			 * between the last-printed value and the current
			 * value (possibly with a repeat count).  Value
			 * separators used are:
			 *
			 *  Adjacent types		  Value separator
			 *
			 *  nonchar, nonchar		  comma and 2 blanks
			 *  delim-char, delim-char	  comma and 2 blanks
			 *  delim-char, nonchar		  comma and 2 blanks
			 *  nondelim-char, nondelim-char  no delimiter
			 *  nondelim-char, other	  space (see note)
			 *
			 * Note: If we are in cf77 compatibility mode, no
			 * value separator is placed between a nondelimited 
			 * character and any other type.
			 *
			 * The comma separator is printed directly to the line
			 * buffer, but the blanks are deferred until we can
			 * determine if the next value fits on the current
			 * record or not.  If we must go to the next record,
			 * the blanks are not printed.
			 */

			if (css->u.fmt.u.le.item1 != 0)
				css->u.fmt.u.le.item1	= 0;

			/*
			 * No value separator between consecutive nondelimited 
			 * character.  One space is used as value separator.
			 */
			else if (ndchar && (prevtyp == DVTYPE_ASCII)) 
				blanks	= 0;
			/*
			 * Use one space as a value separator between 
			 * nondelimited character and non-character values.
			 */
			else if (ndchar || (delim == 0 && prevtyp == DVTYPE_ASCII)) {
				if (cup->ulinemax < cup->uldwsize && cup->uft90) 
					blanks	= _90_char_nonchar_delim_blanks;
				else
					blanks	= 0;
			}

			/*
			 * Else a comma and 2 blanks normally separate
			 * consecutive items.  If the previous output item 
			 * lies out at the very end of the record, we 
			 * suppress the comma.  The leading blank on 
			 * the next record serves as value separator.
			 */
			else {
				if (cup->ulinemax < cup->uldwsize) {
					if (cup->ufcomsep == 0) {
						*(cup->ulineptr++)	= COMMA;
						cup->ulinemax	= cup->ulinemax + 1;
						blanks		= 2;
					} else
						blanks		= 1;
				}
				else
					blanks		= 0;
			}

			/*
			 * Print the repeat count into the item buffer.
			 */

			if (repcnt > 1) {
				long	rcnt;

				rcnt	= repcnt;
				width	= WINT;
				digits	= 1;

				if (sizeof(rcnt) == 4)
					mode	= MODEHP;
#if     defined(_F_INT2) && (defined(__mips) || defined(_LITTLE_ENDIAN))
				else if (sizeof(rcnt) == 2)
					mode	= MODEWP;
				else if (sizeof(rcnt) == 1)
					mode	= MODEBP;
#endif	/* _f_int2 and mips or little endian */
				else
					mode	= 0;

				newp	= _s2ui(&rcnt, plain, &mode, &width,
						&digits, &zero, &zero);

				tptr	= tptr + _beautify(DVTYPE_INTEGER, plain,
							newp, tptr, cup->uft90);
				*tptr++	= STAR;
			}

			/*
			 * Print a saved (delimited) character value.
			 */

			if (prevtyp == DVTYPE_ASCII) {	/* delimited character */
				register int	errn;	/* Error code */

				/*
				 * Check that there's room on the current
				 * line for the blanks, the repeat count,
				 * the asterisk, and the starting delimiter.
				 */

				tbsz	= tptr - tbuf;

				if ((cup->ulinemax + blanks + tbsz + 1) >
				     cup->uldwsize) {

					/*
					 * Check that the repeat specification
					 * (with asterisk), the leading blank,
					 * and the leading delimiter fit on a
					 * single line.
					 */

					if ((tbsz + 2) > cup->uldwsize)
						RERROR(FEWRLONG); /* Record too long */

					/* Write record */

					errn	= (*css->u.fmt.endrec)(css, cup, 1);

					if (errn != 0)
						RERROR(errn);

					/* Write one space at start of new record */

					*(cup->ulineptr++)	= BLANK;
					cup->ulinemax		= cup->ulinemax + 1;
				}
				else {
					/* This loop should vectorize */
#ifdef	_CRAY
#pragma _CRI shortloop
#endif
					for (i = 0; i < blanks; i++)
						cup->ulineptr[i]	= BLANK;

					cup->ulinemax	= cup->ulinemax + blanks;
					cup->ulineptr	= cup->ulineptr + blanks;
				}

				/*
				 * Transfer the optional repeat count (with
				 * asterisk) and the starting delimiter to
				 * the line buffer.
				 */

				for (i = 0; i < tbsz; i++)	/* Should vectorize */
					cup->ulineptr[i]	= tbuf[i];

				cup->ulineptr	= cup->ulineptr + tbsz;
				cup->ulinemax	= cup->ulinemax + tbsz;

				errn	= _write_delimited_char(css, cup, prevptr,
						prevlen, delim);

				if (errn != 0)
					RERROR(errn);

				goto done_printing_saved_value;
			}

			/*
			 * Print a saved non-character value.
			 */

			gcf	= _oldotab[prevtyp];	/* Conversion function */
			mode	= 0;
			expon	= 0;
			scale	= 0;

			switch (prevtyp) {

			case DVTYPE_TYPELESS:
				switch (prevlen) {
				case 4:
					mode	= MODEUN | MODEHP;
					width	= WOCTHWD;
					break;

				case 8:
					mode	= MODEUN;
					width	= WOCTWRD;
					break;

				default:
					return(FEKNTSUP); /* kind not supported */
				}

				digits	= width;
				break;

			case DVTYPE_INTEGER:
				width	= WINT;	
				digits	= 1;

#ifdef	_F_INT4
				if (prevlen == 4) {
					mode	= MODEHP;
					if (cup->ufcomplen != 0)
						width	= WINT4;
#if     defined(_F_INT2) && (defined(__mips) || defined(_LITTLE_ENDIAN))
				} else if (prevlen == 2) {
					mode	= MODEWP;
					if (cup->ufcomplen != 0)
						width	= WINT2;
				} else if (prevlen == 1) {
					mode	= MODEBP;
					if (cup->ufcomplen != 0)
						width	= WINT1;
#endif	/* _F_INT2 and mips or little endian */
				}
#endif	/* _F_INT4 */
				break;

			case DVTYPE_REAL:
			case DVTYPE_COMPLEX:
				scale	= 1;
				realsz	= prevlen; /* bytes */

				if (prevtyp == DVTYPE_COMPLEX)
					realsz	= realsz >> 1;

				switch (realsz) {

					/* 
					 * Use G editing to print 'digits'
					 * of precision with G-as-F conversions
					 * and 'digits' + 1 precision with
					 * G-as-E conversions and a scale
					 * factor of 1.
					 *
					 * We put up with this inconsistency
					 * to avoid having to prescan the datum
					 * to determine its magnitude.
					 */
#ifdef	_F_REAL4
				case 4:
					mode	= MODEHP;

					/*
					 * if ignore-minus-flag of -0.0
					 * set, do not write minus.
					 */

					if (cup->ufnegzero != 0)
						mode	= mode | MODEMSN;

					expon	= DEXP4;

					if (cup->ufcomplen == 0) {
						width	= WREAL4;	
						digits	= _dreal4;
					} else {
						width	= WRL4;	
						digits	= WDIG4;
					}
					break;
#endif
				case 8:

					/* if ignore-minus-flag of -0.0
					 * set, do not write minus.
					 */

					if (cup->ufnegzero != 0)
						mode	= MODEMSN;

					expon	= DEXP8;

					if (cup->ufcomplen == 0) {
						width	= WREAL8;
						digits	= _dreal8;
					} else {
						width	= WRL8;	
						digits	= WDIG8;
					}
					break;

				case 16:
					/*
					 * When printing with D format,
					 * decrease the digits by one because
					 * we are setting the scale factor to
					 * 1.  This ensures that _dreal16
					 * digits of precision are printed.
					 */
					gcf	= _sd2udee;
					mode	= MODEDP;

					/* if ignore-minus-flag of -0.0
					 * set, do not write minus.
					 */

					if (cup->ufnegzero != 0)
						mode	= mode | MODEMSN;
					expon	= DEXP16;
					if (cup->ufcomplen == 0) {
						width	= WREAL16;	
						digits	= _dreal16 - 1;
					} else {
						width	= WRL16;	
						digits	= WDIG16;
					}
					break;

				default:
					return(FEKNTSUP); /* kind not supported */
				}
				break;
			} /* switch */

			/*
			 *	Perform the numeric output conversion.
			 */

			switch (prevtyp) {	/* set up for each data type */
				register long	ldatum;

			default:	/* Integer, Short Integer, Real, or Double */
	
				if (cup->ufcomplen == 0) {
					newp = gcf(prevptr, plain,
					   &mode, &width, &digits,
					   &expon, &scale);
					if (prevtyp == DVTYPE_TYPELESS)
						*newp++	= (int) 'B';
					tptr	= tptr + _beautify(prevtyp, plain,
						newp, tptr, cup->uft90);
				} else {
					newp = gcf(prevptr, tptr,
					   &mode, &width, &digits,
					   &expon, &scale);

					if (prevtyp == DVTYPE_TYPELESS)
						*newp++	= (int) 'B';
					tptr	= tptr + width;

					}
				break;	

			case DVTYPE_COMPLEX:
				*tptr++	= LPAREN;

				if (cup->ufcomplen == 0) {
					newp = gcf(prevptr, plain, &mode,
						&width, &digits, &expon,
						&scale);

					tptr = tptr + _beautify(prevtyp, plain,
						newp, tptr, cup->uft90);

					*tptr++	= COMMA;

					newp = gcf(((char *)prevptr + realsz),
						plain, &mode, &width, &digits,
						&expon, &scale);

					tptr = tptr + _beautify(prevtyp, plain,
						newp, tptr, cup->uft90);
				} else {
					newp = gcf(prevptr, tptr, &mode,
						&width, &digits, &expon,
						&scale);
					tptr	= tptr + width;
					*tptr++	= COMMA;
					newp = gcf(((char *)prevptr + realsz),
						tptr, &mode, &width, &digits,
						&expon, &scale);
					tptr	= tptr + width;
				}
				*tptr++	= RPAREN;

				break;

			case DVTYPE_LOGICAL:
				switch (prevlen) {

#ifdef	_F_LOG4
#if     defined(_F_LOG2) && (defined(__mips) || defined(_LITTLE_ENDIAN))
					case 1:
						ldatum	= *(_f_log1 *)prevptr;
						break;
					case 2:
						ldatum	= *(_f_log2 *)prevptr;
						break;
#endif	/* _F_LOG2 and mips or little endian */
					case 4:
						ldatum	= *(_f_log4 *)prevptr;
						break;
#endif
					case 8:
						ldatum	= *(_f_log8 *)prevptr;
						break;

					default:
						return(FEKNTSUP); /* kind not supported */
				}

				*tptr++ = _lvtob(ldatum) ? (long) 'T' : (long) 'F';
				break;

			} /* switch */

			tbsz	= tptr - tbuf;

			if ((cup->ulinemax + blanks + tbsz) > cup->uldwsize) {
				register int	errn;	/* Error code */

				/*
				 * Check that the item plus leading blank
				 * would fit on a single line.
				 */

				if (tbsz + 1 > cup->uldwsize)
					RERROR(FEWRLONG);	/* Record too long */

				/* Write record */

				errn	= (*css->u.fmt.endrec)(css, cup, 1);

				if (errn != 0)
					RERROR(errn);

				/* Leading blank */

				*(cup->ulineptr++)	= BLANK;
				cup->ulinemax		= cup->ulinemax + 1;
			}
			else {
				if ((cup->ulinemax + blanks) > cup->uldwsize)
					RERROR(FEWRLONG); /* Record too long */

#ifdef	_CRAY
#pragma _CRI shortloop
#endif
				for (i = 0; i < blanks; i++)
					cup->ulineptr[i]	= BLANK;

				cup->ulinemax	= cup->ulinemax + blanks;
				cup->ulineptr	= cup->ulineptr + blanks;
			}

			/*
			 * Now copy the current output from tbuf into the 
			 * line buffer.  We should never exceed the size
			 * of the item buffer since ITEMBUFSIZ is set up
			 * to be sufficiently large for all cases. 
			 */

			if (tbsz > ITEMBUFSIZ)
				_ferr(css, FEINTUNK);	/* deep weeds */

			for (i = 0; i < tbsz; i++)	/* Should vectorize */
				cup->ulineptr[i]	= tbuf[i];

			cup->ulineptr	= cup->ulineptr + tbsz;
			cup->ulinemax	= cup->ulinemax + tbsz;

done_printing_saved_value:
			if (prevlen > sizeof(css->u.fmt.u.le.u.value))
				free(css->u.fmt.u.le.u.copy);

			css->u.fmt.u.le.ndchar	= 0;	/* item was not nondelim char */
			css->u.fmt.u.le.repcnt	= 0;	/* value buffer is now empty */
			ndchar			= 0;
			repcnt			= 0;

		} /* End of saved output processing */

		/*
		 * If count is zero, we are completing list-directed output
		 * statement processing.  
		 */

		if (count == 0)
			goto fin;

		/*
		 * At this point, we are finally ready to handle the new 
		 * output value.  If it is nondelimited character, then we 
		 * print it right out.  Otherwise, we store the value in
		 * the css structure.
		 */

		if (ischar && delim == 0) {	/* If nondelimited character */
			register long	cnt;
			register long	stride;

			/*
			 * Take care of printing the possible value separator.
			 */

			blanks	= 0;

			if (css->u.fmt.u.le.item1)
				css->u.fmt.u.le.item1	= 0;
			else if (!ndchar && cup->uft90 &&
				  cup->ulinemax < cup->uldwsize) 
				blanks	= _90_char_nonchar_delim_blanks;

			/* blanks is always 0 or 1 here */

			assert ( blanks == 0 || blanks == 1 );

			if (blanks > 0) {
				*(cup->ulineptr++)	= BLANK;
				cup->ulinemax		= cup->ulinemax + 1;
			}

			/*
			 * Check for unit stride character data.  These can
			 * be coalesced and transferred as a single datum.
			 */

			cnt	= count;

			if (vinc == 0 || vinc == 1) {
				elsize	= elsize * cnt;
				cnt	= 1;
				vinc	= 1;
			}

			stride	= elsize * vinc;

			for (i = 0; i < cnt ; i++) {
				register int	j;

				for (j = 0; j < elsize; j++) {

					if (cup->ulinemax >= cup->uldwsize) {
						register int	errn;

						/* Write record */

						errn	= (*css->u.fmt.endrec)(css, cup, 1);

						if (errn != 0)
				        		RERROR(errn);

						/* Print blank in column 1 */

						*(cup->ulineptr++)	= BLANK;
						cup->ulinemax	= cup->ulinemax + 1;
					}

					*cup->ulineptr++	= (long) cptr[j];
					cup->ulinemax		= cup->ulinemax + 1;
				}

				cptr	= cptr + stride;
			}

			css->u.fmt.u.le.ndchar	= 1;	/* Set nondelim char */
			css->u.fmt.u.le.repcnt	= 0;	/* Value buffer is empty */

			goto fin;

		} /* End of nondelimited character processing */

		/*
		 * Find the number of consecutive duplicated values in the
		 * current batch of iolist items.
		 */

		if ((count > 1) && (cup->ufrptcnt == 0))
			dupcnt	= _find_dupcnt(cptr, count, vinc, elsize, ischar);
		else
			dupcnt	= 1;

	    	/*
		 * If repcnt is zero, then we save a new value in the css
		 * structure and set the repeat count appropriately.
		 *
		 * If repcnt is nonzero, then we know that the value pointed
		 * to by cptr is equal to that saved with the previous repeat
		 * count.   In this case we simply increase the repeat count
		 * to allow for current data.
		 */

		if (repcnt == 0) {
			void	*valptr;

			if (elsize > sizeof(css->u.fmt.u.le.u.value)) {

				valptr	= malloc(elsize);

				if (valptr == NULL) {
			        	RERROR(FENOMEMY);
				}

				css->u.fmt.u.le.u.copy	= valptr;
			}
			else
				valptr	= &css->u.fmt.u.le.u.value[0];

			/* Copy the possibly repeated value */

			if (ischar)	/* If character variable */
				(void) memcpy(valptr, cptr, elsize);
			else {
				/* On Mips systems, it's possible to have */
				/* elsize == sizeof(long), but the */
				/* item is not aligned on a long boundary */
				/* e.g., Complex data in the 64bit-ABI */
				if (elsize == sizeof(int))
					*(int *) valptr	= *(int *) cptr;
				else if (elsize == sizeof(short))
					*(short *) valptr	= *(short *) cptr;
				else
					(void) memcpy(valptr, cptr, elsize);
			}
		}

		repcnt			= repcnt + dupcnt;
		css->u.fmt.u.le.repcnt	= repcnt;
		css->u.fmt.u.le.type	= type;
		css->u.fmt.u.le.elsize	= elsize;

		/* Decrement count and advance data address */

done:
		count	= count - dupcnt;
		cptr	= cptr + (dupcnt * vinc * elsize);

	} /* while */

#ifdef	_CRAYT3D
	continue;
   } while (shared && offset < tcount);
#endif

fin:
	return(0);
}

/*
 *	_find_dupcnt
 *		Find and return the repeat count.  
 *
 *	Return Value
 *		The number of times the first datum is repeated
 * 		consecutively in the data list.  If the datum is
 *		not repeated, a value of one is returned.
 */ 

int
_find_dupcnt(
	void	*ptr,	/* Pointer to data		*/
	long	count,	/* Maximum number of data items	*/
	long	stride,	/* Stride between items (in units of elsize)	*/
	int	elsize,	/* Bytes per datum		*/
	short	ischar)	/* Is type == CHARACTER?	*/
{
	register long	i;

	/* Assertions */

	assert ( ptr != NULL );
	assert ( count > 1 );
	assert ( elsize > 0 );

	if (! ischar && elsize != sizeof(char)) {/* If not character or 1 byte*/
#if	(!defined(_WORD32) && ( defined(_F_INT4) || defined(_F_REAL4))) \
	|| defined(__mips) || defined(_LITTLE_ENDIAN)
		if (elsize == sizeof(short)) {
			register short	value;
			short		*sptr;

			sptr	= (short *) ptr;
			value	= *sptr;
 
                        for (i = 1; i < count; i++) {

				sptr	= sptr + stride;

				if (value != *sptr)
					break;
                        }
		}
		else
#endif	/* (not _word32 and (_f_int4 or _f_real4)) or mips or little endian */
		if (elsize == sizeof(int)){ 
			register int	value;
			int		*lptr;

			lptr	= (int *) ptr;
			value	= *lptr;

			for (i = 1; i < count; i++) {

				lptr	= lptr + stride;

				if (value != *lptr)
					break;
			}
		}
		else {				/* elsize > sizeof(int) */
			register int	words;
			register int	linc;
			int		*p1, *p2;

			words	= elsize / sizeof(int);
			linc	= stride * words;
			p1	= (int * ) ptr;
			p2	= p1 + linc;

			for (i = 1; i < count; i++) {
				register int	j;

#ifdef	_CRAY
#pragma _CRI shortloop
#endif
				for (j = 0; j < words; j++)
					if ((p1[j] != p2[j]))
						goto done;

				p2	= p2 + linc;
			}
		}
	}
	else {			/* Character */
		register long	cinc;
		char		*pchr;

		cinc	= elsize * stride;
		pchr	= ((char *) ptr) + cinc;

		for (i = 1; i < count; i++) {

			if (memcmp(ptr, pchr, elsize) != 0)
				break;

			pchr	= pchr + cinc;
		}
	}

done:
	return(i);
}

/*
 *	_beautify 
 *
 *		Beautify numeric output by deleting blanks and
 *		truncating unnecessary trailing zeroes.  The altered
 *		ascii number is placed in "pretty".
 *
 *		Input is in this form: {LH part}[{E}{exponent}]
 *
 *	Return value:
 *		The number of characters in the beautified output.
 */
int
_beautify(
	ftype_t	type,		/* Data type of the number */
	long	*plain,		/* Raw ascii representation of a number */
	long	*limit,		/* Pointer to one past end of ASCII data in plain */
	long	*pretty,	/* Receives the beautified output */
	short	isf90)		/* 1 iff Fortran 90 style printing of 0.E+0 */ 
{
	register short	i;
	register short	length;
	long		*p, *start, *exp, *end;

	/* Point start to the first nonblank character */

	start	= plain;

	while (*start == BLANK)
		start	= start + 1;

	/* Point end one past the last nonblank character */ 

	end	= limit;		/* find end point */

	while (*(end - 1) == BLANK)
		end	= end - 1;

	if (type == DVTYPE_TYPELESS || type == DVTYPE_INTEGER) {

		length	= end - start;

		/* The following loop should vectorize */

#ifdef	_MAXVL
		assert (length < 64);

#pragma _CRI shortloop
#endif
		for (i = 0; i < length; i++)
			pretty[i]	= start[i];

		return((int) length);
	}

/*
 *	Point exp to the 'E'.  Assign it NULL if there is not 'E' in the 
 *	number (integer or F format style).
 */
	exp	= NULL;

	for (p = end - 1; p > start; p--) {
		if (*p == (long) 'E') {
			exp	= p;
			break;
		}
	}

	if (exp != NULL) {	/* If E format output */
		long	*zero;

		zero	= exp;

		/*
		 * Point zero to one place past the last nonzero digit in 
		 * the LH part. 
		 */

		while ( *(zero - 1) == ZERO)
			zero	= zero - 1;		

		/*
		 * Copy 'E+(-)'.  Then zero is advanced to the future
		 * location of the exponent, and exp is pointed to the
		 * current location of the exponent.  
		 */

		*zero++	= *exp++;
		*zero++	= *exp++;

		/* 
		 * Remove all leading zeroes in the exponent.  Do not remove
		 * a zero exponent though.  Let the G editing output function
		 * called previously or the 0 beautification below be 
		 * responsible for choosing the F or E edit descriptor output 
		 * form.
		 */

		while (exp < (end - 1) && *exp == ZERO)  
			exp	= exp + 1;

		while (exp < end)
			*zero++	= *exp++;

		end	= zero;
	}
	else {			/* Else if F format output */
		while (*(end - 1) == ZERO)
			end	= end - 1;	/* trim trailing zeroes */
	}

	length	= end - start;

	/* The following loop should vectorize */

#ifdef	_MAXVL
		assert (length < 64);

#pragma _CRI shortloop
#endif
	for (i = 0; i < length; i++)
		pretty[i]	= start[i];

/*
 *	Floating point 0 values, both single and double precision, are
 *	printed as:
 *
 *		If in Fortran 90 mode:		 0.E+0
 *		If in CF77 mode:		 0.
 */

	if (pretty[0] == ZERO && pretty[1] == PERIOD &&
	    (length == 2 || (length > 2 && pretty[2] == (long) 'E'))) {

		length	= 2;

		if (isf90) {
			pretty[length++]	= (long) 'E';
			pretty[length++]	= PLUS;
			pretty[length++]	= ZERO;
		}
	}

	return (length);	/* return length of beautified output */
}

/*
 *	_write_delimited_char
 *		Write out to the line buffer a delimited character value
 *		with internal doubling of the delimiter characters.  If
 *		the value will not fit on the current line, spill to 
 *		subsequent lines as needed.  (On subsequent lines, no extra
 *		space character is is placed in column 1).
 *
 *	Return value:
 *
 *		 0 on success.  
 *		>0 error code if an error condition is encountered.
 */
int
_write_delimited_char(
	FIOSPTR	css,		/* Fortran statement state */
	unit	*cup,		/* Unit pointer */
	char	*sptr,		/* Pointer to string */
	int	len,		/* Length of string to be printed */
	long	dchar		/* delimiter character to use */
)
{
	register short	eoln;	/* End of line flag */
	register int	errn;	/* Error code */

/*
 *	Print out the opening delimiter.
 */
	if (cup->ulinemax >= cup->uldwsize) {

		errn	= (*css->u.fmt.endrec)(css, cup, 1);

		if (errn != 0)
			return(errn);

		if (css->f_iostmt == T_WNL && !cup->uft90) {
			cup->ulinemax           = cup->ulinemax + 1;
			*(cup->ulineptr++)      = BLANK;
		}
	}

	*(cup->ulineptr++)	= dchar;	
	cup->ulinemax		= cup->ulinemax + 1;
/*
 *	Print out the string.
 */
	eoln	= 0;

	while (len > 0) {
		if (eoln) {

			errn	= (*css->u.fmt.endrec)(css, cup, 1);

			if (errn != 0)
				return(errn);

			eoln	= 0;

			if (css->f_iostmt == T_WNL && !cup->uft90) {
				cup->ulinemax           = cup->ulinemax + 1;
				*(cup->ulineptr++)      = BLANK;
			}
		}

		if (*sptr == (char) dchar) {
			/*
			 * Next part of string is an imbedded delimiter 
			 * character.  Double the delimiter character.
			 */
			if ((cup->ulinemax + 2) > cup->uldwsize)
				eoln	= 1;
			else {
				*(cup->ulineptr++)	= dchar;	
				*(cup->ulineptr++)	= dchar;	
				cup->ulinemax		= cup->ulinemax + 2;
				len			= len - 1;
				sptr			= sptr + 1;
			}
		}
		else {
			/*
			 * Process a chunk of the string which contains no 
			 * imbedded delimiter characters and can fit on the 
			 * current line.
			 */

			if (cup->ulinemax >= cup->uldwsize)
				eoln	= 1;
			else {
				register int	chunk;
				char		*nxtdelm;

				chunk	= cup->uldwsize - cup->ulinemax;
				chunk	= (len < chunk) ? len : chunk;

				nxtdelm	= memchr(sptr, (int) dchar, chunk);

				if (nxtdelm != NULL)
					chunk	= nxtdelm - sptr;

				(void) _unpack(sptr, cup->ulineptr, chunk, -1);

				cup->ulinemax	= cup->ulinemax + chunk;
				cup->ulineptr	= cup->ulineptr + chunk;
				len		= len - chunk;
				sptr		= sptr + chunk;
			}
		}
	} /* while */

/*
 *	Print out the closing delimiter.
 */
	if (cup->ulinemax >= cup->uldwsize) {

		errn	= (*css->u.fmt.endrec)(css, cup, 1);

		if (errn != 0)
			return(errn);

		if (css->f_iostmt == T_WNL && !cup->uft90) {
			cup->ulinemax           = cup->ulinemax + 1;
			*(cup->ulineptr++)      = BLANK;
		}
	}

	*(cup->ulineptr++)	= dchar;	
	cup->ulinemax		= cup->ulinemax + 1;

	return(0);
}

/*
 *	_lwrite_setup
 *
 *		Access the LISTIO_PRECISION environment variable to choose 
 *		between styles of list directed output of reals.
 *
 *		FULL    - full precision output.   This ensures that all digits
 *			  with any precision (and possibly some with no
 *		  	  precision) are printed.  This is default.
 *		PRECISION - the number of digits printed is P or P+1,
 *			  depending on whether the library chooses
 *			  F or E format.  P is the value of the 
 *			  F90 PRECISION() intrinsic function.
 *		YMP80     - the number of digits printed is compatible with
 *			  UNICOS 8.0 and previous.   This is available only
 *			  on YMP/C90/TS systems.
 *		F77	  - the number of digits printed is mostly compatible 
 *			  with that chosen by the Sparc f77 compiler.  This
 *			  is available only on Sparc, and only for internal
 *			  use.
 *
 *
 *		This function is called by _initialize_fortran_io()
 */
void
_lwrite_setup(void)        
{
	char	*str;

#ifdef	_F_REAL4
	_dreal4		= DREAL4;
#endif

	_dreal8		= DREAL8;
	_dreal16	= DREAL16;

/*
 *	The LISTIO_PRECISION environment variable can be set to specify
 *	a choice in the number of digits of precision requested for real
 *	values being printed via list directed output.
 */
	str	= getenv("LISTIO_PRECISION");

	if (str != NULL) {
		if (strcmp(str, "FULL") == 0) {
			_dreal8		= DREAL8;
			_dreal16	= DREAL16;
		}
		else if (strcmp(str, "PRECISION") == 0) {
#ifdef	_F_REAL4
			_dreal4		= DREAL4_P;
#endif
			_dreal8		= DREAL8_P;
			_dreal16	= DREAL16_P;
		}
		else if (strcmp(str, "YMP80") == 0) {
			_dreal8		= DREAL8_YMP80;
			_dreal16	= DREAL16_YMP80;
		}
		else if (strcmp(str, "F77") == 0) {	/* internal use only */
#ifdef	_F_REAL4
			_dreal4		= 6;
#endif
			_dreal8		= 14;
		}
	}

/*
 *	The LISTIO_OUTPUT_STYLE environment variable can be set to 'OLD' 
 *	to cause list-directed output to be more consistent with CrayLibs 1.2.  
 *	Specifically, this will cause the following effects:
 *
 * 		1) Repeat counts will not span separate calls to _ld_write().
 *		2) A space will not be printed as a value separator between
 *		   non-delimited character and non-character output list items
 *		   in F90 mode (if cup->uft90==1).
 *		3) A space will not be printed in column 1 of a list-directed
 *		   WRITE statement containing no I/O list items.
 *
 */
	str	= getenv("LISTIO_OUTPUT_STYLE");

	if (str != NULL && strcmp(str, "OLD") == 0) {
		_old_list_out_repcounts		= 1;
		_90_char_nonchar_delim_blanks	= 0;
		_blank_at_start_of_empty_rec	= 0;
	}

	return;
}
