Computational routine
eng
writef4
#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=GetScicosTime(block);
/* 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