osprey/libf/fio/wrunf.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

*/



#ifndef INLINE
#pragma ident "@(#) libf/fio/wrunf.c  92.2  06/21/99 10:37:55"
#endif

#include <errno.h>
#include <liberrno.h>
#include <fortran.h>
#include <cray/nassert.h>
#ifdef  _CRAYT3D
#include <cray/mppsdd.h>
#endif
#include "fio.h"
#include "f90io.h"

#define LOCBUFLN 4096

/*
 *  _wrunf()  Write unformatted processing.
 *
 *  Return value
 *
 *     0  normal return.
 *
 *    >0  if error condition and IOSTAT= or ERR= is
 *      specified.
 */

#ifdef  INLINE
static int
_inline_wrunf(
#else
int
_wrunf(
#endif
  FIOSPTR   css,  /* Current Fortran I/O statement state */
  unit    *cup, /* Unit pointer */
  void    *ptr, /* Pointer to data */
  type_packet *tip, /* Type information packet */
  int   mode  /* Mode argument to _fwwd() */
)
{
  register short  shared;   /* 1 iff ptr points to sdd */
  register int  errn;   /* Error number */
  register int64  fillen;   /* bit size of each element, on disk */
  register long count;    /* Number of data items */
  register long elsize;   /* element size in bytes */
  register long i;
  register long incb;   /* inc (in units of bytes) */
  register long items;
  long    lbuf[LOCBUFLN]; 
  void    *fwwdbuf; /* ptr to buffer passed to _fwwd */
#ifdef  _CRAYT3D
  register long elwords;  /* element size in words */
#endif

  errn  = 0;
  shared  = 0;
  count = tip->count;
  elsize  = tip->elsize;
  fillen  = tip->extlen;

  if (count == 0)
    return(0);

  if (tip->type90 == DVTYPE_ASCII)
    fillen  = fillen * elsize;

  incb  = tip->stride * elsize; /* Stride in bytes */

  if (cup->useq == 0) { /* If direct access file */
    register int64  newpos;
    register int64  recl;

    newpos  = cup->urecpos + count * fillen; /* in bits */
    recl  = (int64) (cup->urecl);

    if ((recl << 3) < newpos) {
      errn  = FEWRLONG; /* output record too long */
      goto done;
    }
  }

#ifdef  _CRAYT3D
  if (_issddptr(ptr)) {
    /* ptr points to a shared data descriptor */
    /* If we have a layer that handles sdds someday, we */
    /* could check for that here and not set shared to one. */
    /* We'd also probably want to make sure that we're not */
    /* doing foreign data converion */
    shared  = 1;
    elwords = elsize / sizeof(long);
  }
#endif

/*
 *  If only one item, or stride is such that data is contiguous,
 *  do it all at once
 */
  if ((shared == 0) && ((count == 1) || (incb == elsize))) {
    register long ret;
    int   status;

    if (mode == FULL)
      cup->f_lastwritten = 1;

    ret = _fwwd(cup, ptr, tip, mode, (int *) NULL,
        (long *) NULL, &status);

    if ( ret == IOERR ) {
      errn  = errno;
      goto done;
    }

    return(0);
  }

/*
 *  Stride is such that memory is not contiguous, break the request
 *  into chunks and do a gaterh on the items before writing.
 */

  items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it in chunks */

  assert( ! (shared && items == 0) ); /* don't support shared char */

  if (items == 0)
    items = 1;      /* must be character*BIG array*/

  fwwdbuf = lbuf;

  for ( i = 0; i < count; i = i + items ) {
    register long ret;
    int   status;

    /* trim the item count if not a full buffer's worth */

    if (items > count - i)
      items = count - i;

    tip->count  = items;

    /*
     * Gather items from user array into lbuf, and then write
     * out a chunk.  If items == 1, we suppress the extra data
     * copy for performance and because it might not fit in the
     * lbuf if it is character*BIG data.
     *
     * We don't have to worry about shared data not fitting 
     * in lbuf since character data is never shared.
     */ 

#ifdef  _CRAYT3D
    if (shared)
      _cpyfrmsdd(ptr, lbuf, items, elwords, tip->stride, i);
    else
#endif
    {
      if (items > 1) 
        _gather_data (lbuf, items, incb, elsize, ptr);
      else 
        fwwdbuf = ptr;
    
    }

    if ( mode == FULL && (i+items >= count)) {
      cup->f_lastwritten = 1;
      ret = _fwwd(cup, fwwdbuf, tip, FULL, (int *) NULL,
          (long *) NULL, &status);
    }
    else
      ret = _fwwd(cup, fwwdbuf, tip, PARTIAL,
          (int *) NULL, (long *) NULL, &status);

    if ( ret == IOERR ) {
      errn  = errno; 
      goto done;
    }

    if (!shared)
      ptr = (char *)ptr + (ret * incb);
  }

done:
  if (errn > 0) {
    if ((cup->uflag & (_UERRF | _UIOSTF)) == 0)
      _ferr(css, errn); /* Run-time error */
  }
    
  return(errn);
}

---