osprey/libf/fio/lwrite.c

Go to the documentation of this file.

/*

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

  This program is free software; you can redistribute it and/or modify it
  under the terms of version 2.1 of the GNU Lesser General Public License 
  as published by the Free Software Foundation.

  This program is distributed in the hope that it would be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  

  Further, this software is distributed without any warranty that it is
  free of the rightful claim of any third person regarding infringement 
  or the like.  Any license provided herein, whether implied or 
  otherwise, applies only to this software file.  Patent licenses, if
  any, provided herein do not apply to combinations of this program with 
  other software, or any other product whatsoever.  

  You should have received a copy of the GNU Lesser General Public 
  License along with this program; if not, write the Free Software 
  Foundation, Inc., 59 Temple Place - Suite 330, Boston MA 02111-1307, 
  USA.

  Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
  Mountain View, CA 94043, or:

  http://www.sgi.com

  For further information regarding this notice, see:

  http://oss.sgi.com/projects/GenInfo/NoticeExplan

*/



#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;
}

---