writef4.c

Go to the documentation of this file.

#include "scicos_block.h"
#include <math.h>
#include "machine.h"


/* Common Block Declarations */

struct {
    double stk[2];
} stack_;

#define stack_1 stack_

struct {
    int bot, top, idstk[60000]  /* was [6][10000] */, lstk[10000], 
            leps, bbot, bot0, infstk[10000], gbot, gtop, isiz;
} vstk_;

#define vstk_1 vstk_

struct {
    int ids[24576]      /* was [6][4096] */, pstk[4096], rstk[4096], pt, niv, 
            macr, paus, icall, krec;
} recu_;

#define recu_1 recu_

struct {
    int ddt, err, lct[8], lin[65536], lpt[6], hio, rio, wio, rte, wte;
} iop_;

#define iop_1 iop_

struct {
    int err1, err2, errct, toperr, errpt, ieee, catch__;
} errgst_;

#define errgst_1 errgst_

struct {
    int sym, syn[6], char1, fin, fun, lhs, rhs, ran[2], comp[3];
} com_;

#define com_1 com_

struct {
    char alfa[63], alfb[63], buf[4096];
} cha1_;

#define cha1_1 cha1_

struct {
    int wmac, lcntr, nmacs, macnms[600] /* was [6][100] */, lgptrs[
            101], bptlg[1000];
} dbg_;

#define dbg_1 dbg_

struct {
    int lbot, ie, is, ipal, nbarg, ladr[1024];
} adre_;

#define adre_1 adre_

struct {
    int nbvars, iwhere[1024], nbrows[1024], nbcols[1024], itflag[1024], 
            ntypes[1024], lad[1024], ladc[1024], lhsvar[1024];
} intersci_;

#define intersci_1 intersci_

typedef struct
{       long int cierr;
        long int ciunit;
        long int ciend;
        char *cifmt;
        long int cirec;
} cilist;

typedef char *address;

typedef struct { double r, i; } doublecomplex;

/* Table of constant values */

static int c__1 = 1;
static double c_b12 = 0.;
static int c__3 = 3;

int writef4(scicos_block *block,int flag)
{
  double* z__=block->z;
  double* u=block->inptr[0];  
  int* nu=block->insz;
  int* ipar=block->ipar;
  int nevprt=block->nevprt;
  double t=get_scicos_time();

  /* System generated locals */
  address a__1[3];
  int i__1, i__2, i__3, i__4[3];
  char ch__1[4118];
  cilist ci__1;
  
  /* Builtin functions */
  int s_wsfe(), do_fio(), e_wsfe(), s_wsue(), do_uio(), e_wsue();
  int s_cat();
  
  /* Local variables */
  static int mode[2], lfil;
  extern int dset_();
  static int lfmt;
#define cstk ((char *)&stack_1)
#define istk ((int *)&stack_1)
#define sstk ((real *)&stack_1)
#define zstk ((doublecomplex *)&stack_1)
  static int i__, j, k, n, iflag, lunit;
  extern int cvstr_();
  static int io;
  extern int basout_(), clunit_();
  
  /* Fortran I/O blocks */
  static cilist io___10 = { 1, 0, 0, 0, 0 };
  static cilist io___14 = { 0, 0, 0, 0, 0 };
  
  
  /*     Copyright INRIA */
  /*     Scicos block simulator */
  /*     write input to a binary or formatted file */
  /*     ipar(1) = lfil : file name length */
  /*     ipar(2) = lfmt : format length (0) if binary file */
  /*     ipar(3)          unused */
  /*     ipar(4) = N : buffer length */
  /*     ipar(5:4+lfil) = character codes for file name */
  /*     ipar(5+lfil:4+lfil+lfmt) = character codes for format if any */
  
  /* Copyright INRIA */
  /* *------------------------------------------------------------------ */
  /* vsiz  size of internal scilab stack */
  
  /* bsiz  size of internal chain buf */
  
  /* isizt  maximum number of scilab variables global and local */
  /* isiz maximum number of scilab local variables */
  /* psiz  defines recursion size */
  /* lsiz  dim. of vector containing the command line */
  /* nlgh  length of variable names */
  /* csiz  used for character coding */
  /* intersiz used in interfaces */
  /* *------------------------------------------------------------------- */
  /* c (DLL Digital Visual Fortran) */
  /* DEC$ IF DEFINED (FORDLL) */
  /* DEC$ ATTRIBUTES DLLIMPORT:: /stack/, /vstk/, /recu/, /iop/ */
  /* DEC$ ATTRIBUTES DLLIMPORT:: /errgst/, /com/, /adre/ */
  /* DEC$ ATTRIBUTES DLLIMPORT:: /intersci/ ,/cha1/ */
  /* DEC$ ENDIF */
  /*     --------------------------------------------------------------- */
  
  /* *------------------------------------------------------------------ */
  
  /* Parameter adjustments */
  --u;
  --ipar;
  --z__;
  
  /* Function Body */
  n = ipar[4];
  k = (int) z__[1];
  lunit = (int) z__[2];
  
  if (flag == 2 && nevprt > 0) {
    /*     add new point to the buffer */
    ++k;
    z__[k + 2] = t;
    i__1 = *nu;
    for (i__ = 1; i__ <= i__1; ++i__) {
      z__[n + 2 + (i__ - 1) * n + k] = u[i__];
      /* L1: */
    }
    z__[1] = (double) k;
    if (k < n) {
      return 0;
    }
    /*     write on the file */
    if (ipar[2] > 0) {
      /*     .     formatted write */
      cvstr_(&ipar[2], &ipar[ipar[1] + 5], cha1_1.buf, &c__1, (short)
             4096);
      i__1 = k;
      for (j = 1; j <= i__1; ++j) {
        ci__1.cierr = 1;
        ci__1.ciunit = lunit;
        ci__1.cifmt = cha1_1.buf;
        i__2 = s_wsfe(&ci__1);
        if (i__2 != 0) {
          goto L100;
        }
        i__3 = *nu;
        for (i__ = 0; i__ <= i__3; ++i__) {
          i__2 = do_fio(&c__1, (char *)&z__[n + 2 + (i__ - 1) * n + 
                                            j], (short)sizeof(double));
          if (i__2 != 0) {
            goto L100;
          }
        }
        i__2 = e_wsfe();
        if (i__2 != 0) {
          goto L100;
        }
        /* L10: */
      }
    } else {
      /*     .     unformatted write */
      i__1 = k;
      for (j = 1; j <= i__1; ++j) {
        io___10.ciunit = lunit;
        i__2 = s_wsue(&io___10);
        if (i__2 != 0) {
          goto L100;
        }
        i__3 = *nu;
        for (i__ = 0; i__ <= i__3; ++i__) {
          i__2 = do_uio(&c__1, (char *)&z__[n + 2 + (i__ - 1) * n + 
                                            j], (short)sizeof(double));
          if (i__2 != 0) {
            goto L100;
          }
        }
        i__2 = e_wsue();
        if (i__2 != 0) {
          goto L100;
        }
        /* L11: */
      }
    }
    z__[1] = 0.;
  } else if (flag == 4) {
    /*     file opening */
    lfil = ipar[1];
    cvstr_(&lfil, &ipar[5], cha1_1.buf, &c__1, (short)4096);
    lfmt = ipar[2];
    lunit = 0;
    if (lfmt > 0) {
      mode[0] = 3;
      mode[1] = 0;
      clunit_(&lunit, cha1_1.buf, mode, lfil);
      if (iop_1.err > 0) {
        goto L100;
      }
    } else {
      mode[0] = 103;
      mode[1] = 0;
      clunit_(&lunit, cha1_1.buf, mode, lfil);
      if (iop_1.err > 0) {
        goto L100;
      }
    }
    z__[1] = 0.;
    z__[2] = (double) lunit;
    z__[3] = t;
    i__1 = *nu * n;
    dset_(&i__1, &c_b12, &z__[4], &c__1);
  } else if (flag == 5) {
    if (lunit == 0) {
      return 0;
    }
    if (k >= 1) {
      /*     write on the file */
      lfmt = ipar[2];
      if (lfmt > 0) {
        /*     .        formatted write */
        cvstr_(&lfmt, &ipar[ipar[1] + 5], cha1_1.buf, &c__1, (short)
               4096);
        i__1 = k;
        for (j = 1; j <= i__1; ++j) {
          ci__1.cierr = 0;
          ci__1.ciunit = lunit;
          ci__1.cifmt = cha1_1.buf;
          s_wsfe(&ci__1);
          i__2 = *nu;
          for (i__ = 0; i__ <= i__2; ++i__) {
            do_fio(&c__1, (char *)&z__[n + 2 + (i__ - 1) * n + j],
                   (short)sizeof(double));
          }
          e_wsfe();
          /* L20: */
        }
      } else {
        /*     .        unformatted write */
        i__1 = k;
        for (j = 1; j <= i__1; ++j) {
          io___14.ciunit = lunit;
          s_wsue(&io___14);
          i__2 = *nu;
          for (i__ = 0; i__ <= i__2; ++i__) {
            do_uio(&c__1, (char *)&z__[n + 2 + (i__ - 1) * n + j],
                   (short)sizeof(double));
          }
          e_wsue();
          /* L21: */
        }
      }
    }
    lfil = ipar[1];
    i__1 = -lunit;
    clunit_(&i__1, cha1_1.buf, mode, lfil);
    if (iop_1.err > 0) {
      goto L100;
    }
    z__[2] = 0.;
  }
  return 0;
 L100:
  iop_1.err = 0;
  /* Writing concatenation */
  i__4[0] = 5, a__1[0] = "File ";
  i__4[1] = lfil, a__1[1] = cha1_1.buf;
  i__4[2] = 17, a__1[2] = " Cannot be opened";
  s_cat(ch__1, a__1, i__4, &c__3, (short)4118);
  basout_(&io, &iop_1.wte, ch__1, lfil + 22);
  iflag = -1;
  return 0;
} /* writef_ */

#undef zstk
#undef sstk
#undef istk
#undef cstk

---