/*------------------------------------------------------------------------ * Copyright (C) 1998-2000 Enpc/Inria * jpc@cereve.enpc.fr --------------------------------------------------------------------------*/ /*------------------------------------------ * Scilab stack *------------------------------------------*/ #include #include #ifdef __STDC__ #include #else #include #endif #include "../stack-c.h" #include "../system/msgstore.h" /* Table of constant values */ static integer cx0 = 0; static integer cx1 = 1; static integer cx4 = 4; static int c_true = TRUE_; static int c_false = FALSE_; static int C2F(getwsmati) __PARAMS((char * fname, integer *topk, integer * spos,integer * lw,integer * m, integer *n,integer * ilr,integer * ilrd ,int * inlistx,integer* nel,unsigned long fname_len)); /********************************************************************** * MATRICES **********************************************************************/ /*------------------------------------------------------------------ * getlistmat : * checks that spos object is a list * checks that lnum-element of the list exists and is a matrix * extracts matrix information(it,m,n,lr,lc) * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position * Out : * [it,m,n] matrix dimensions * lr : stk(lr+i-1)= real(a(i)) * lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 *------------------------------------------------------------------ */ int C2F(getlistmat)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *lnum, *it, *m, *n, *lr, *lc; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * getmat : * check that object at position lw is a matrix * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position ( ``in the top sense'' ) * Out : * [it,m,n] matrix dimensions * lr : stk(lr+i-1)= real(a(i)) * lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 *------------------------------------------------------------------- */ int C2F(getmat)(fname, topk, lw, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *lw, *it, *m, *n, *lr, *lc; unsigned long fname_len; { return C2F(getmati)(fname, topk, lw,Lstk(*lw), it, m, n, lr, lc, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------ * getrmat like getmat but we check for a real matrix *------------------------------------------------------------------ */ int C2F(getrmat)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { integer lc, it; if ( C2F(getmat)(fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE_ ) return FALSE_; if (it != 0) { Scierror(202,"%s: Argument %d: wrong type argument expecting a real matrix\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; } return TRUE_; } /* ------------------------------------------------------------------ * getcmat like getmat but we check for a complex matrix *------------------------------------------------------------------ */ int C2F(getcmat)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { integer lc, it; if ( C2F(getmat)(fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE_ ) return FALSE_; if (it != 1) { Scierror(202,"%s: Argument %d: wrong type argument expecting a complex matrix\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------ * matsize : * like getmat but here m,n are given on entry * and we check that matrix is of size (m,n) *------------------------------------------------------------------ */ int C2F(matsize)(fname, topk, lw, m, n, fname_len) char *fname; integer *topk, *lw, *m, *n; unsigned long fname_len; { integer m1, n1, lc, it, lr; if ( C2F(getmat)(fname, topk, lw, &it, &m1, &n1, &lr, &lc, fname_len) == FALSE_) return FALSE_; if (*m != m1 || *n != n1) { Scierror(205,"%s: Argument %d: wrong matrix size (%d,%d) expected \r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk), *m,*n); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(getmati)(fname, topk, spos, lw, it, m, n, lr, lc, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *it, *m, *n, *lr, *lc; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 1) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a real or complex matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(201,"%s: argument %d should be a real or complex matrix\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); *it = *istk(il + 3); *lr = sadr(il+4); if (*it == 1) *lc = *lr + *m * *n; return TRUE_; } /*---------------------------------------------------------- * listcremat(top,numero,lw,....) * le numero ieme element de la liste en top doit etre un matrice * stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que stk(top+1) * si l'element a creer est le dernier * lw est aussi mis a jour *---------------------------------------------------------- */ int C2F(listcremat)(fname, lw, numi, stlw, it, m, n, lrs, lcs, fname_len) char *fname; integer *lw, *numi, *stlw, *it, *m, *n, *lrs, *lcs; unsigned long fname_len; { integer ix1,il ; if (C2F(cremati)(fname, stlw, it, m, n, lrs, lcs, &c_true, fname_len)==FALSE_) return FALSE_ ; *stlw = *lrs + *m * *n * (*it + 1); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * cremat : * checks that a matrix [it,m,n] can be stored at position lw * <> to real and imaginary part are returned on success * In : * lw : position (entier) * it : type 0 ou 1 * m, n dimensions * Out : * lr : stk(lr+i-1)= real(a(i)) * lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 * Side effect : if matrix creation is possible * [it,m,n] are stored in Scilab stack * and lr and lc are returned * but stk(lr+..) and stk(lc+..) are unchanged *---------------------------------------------------------- */ int C2F(cremat)(fname, lw, it, m, n, lr, lc, fname_len) char *fname; integer *lw, *it, *m, *n, *lr, *lc; unsigned long fname_len; { if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(cremati)(fname, Lstk(*lw ), it, m, n, lr, lc, &c_true, fname_len) == FALSE_) return FALSE_ ; *Lstk(*lw +1) = *lr + *m * *n * (*it + 1); return TRUE_; } /*------------------------------------------------- * Similar to cremat but we only check for space * no data is stored *-------------------------------------------------*/ int C2F(fakecremat)(lw, it, m, n, lr, lc) integer *lw, *it, *m, *n, *lr, *lc; { if (*lw + 1 >= Bot) return FALSE_; if (C2F(cremati)("cremat", Lstk(*lw ), it, m, n, lr, lc, &c_false, 6L) == FALSE_) return FALSE_; *Lstk(*lw +1) = *lr + *m * *n * (*it + 1); return TRUE_; } /*--------------------------------------------------------- * internal function used by cremat and listcremat *---------------------------------------------------------- */ int C2F(cremati)(fname, stlw, it, m, n, lr, lc, flagx, fname_len) char *fname; integer *stlw, *it, *m, *n, *lr, *lc; int *flagx; unsigned long fname_len; { integer ix1; integer il; double size = ((double) *m) * ((double) *n) * ((double) (*it + 1)); il = iadr(*stlw); ix1 = il + 4; Err = sadr(ix1) - *Lstk(Bot ); if ( (double) Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; if (*flagx) { *istk(il ) = 1; /* if m*n=0 then both dimensions are to be set to zero */ *istk(il + 1) = Min(*m , *m * *n); *istk(il + 2) = Min(*n ,*m * *n); *istk(il + 3) = *it; } ix1 = il + 4; *lr = sadr(ix1); *lc = *lr + *m * *n; return TRUE_; } /********************************************************************** * INT MATRICES **********************************************************************/ /* compute requested memory in number of ints */ #define memused(it,mn) ((((mn)*( it % 10))/sizeof(int))+1) /*------------------------------------------------------------------ * getilistmat : * checks that spos object is a list * checks that lnum-element of the list exists and is an int matrix * extracts matrix information(it,m,n,lr) * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position * Out : * [it,m,n] matrix dimensions * it : 1,2,4,11,12,14 * lr : istk(lr+i-1) : matrix data must be properly cast * according to it value *------------------------------------------------------------------ */ int C2F(getlistimat)(fname, topk, spos, lnum,it, m, n, lr, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n, *lr,*it; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getimati)(fname, topk, spos, &ili,it, m, n, lr, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * getimat : * check that object at position lw is an int matrix * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position ( ``in the top sense'' ) * Out : * [it,m,n] matrix dimensions * lr : istk(lr+i-1)= a(i) *------------------------------------------------------------------- */ int C2F(getimat)(fname, topk, lw,it, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr,*it; unsigned long fname_len; { return C2F(getimati)(fname, topk, lw,Lstk(*lw),it,m, n, lr,&c_false, &cx0, fname_len); } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(getimati)(fname, topk, spos, lw, it,m, n, lr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n, *lr,*it; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 8 ) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be an int matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(201,"%s: argument %d should be a real or complex matrix\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); *it = *istk(il + 3); *lr = il+4; return TRUE_; } /*---------------------------------------------------------- * listcreimat(top,numero,lw,....) * le numero ieme element de la liste en top doit etre un matrice * stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que stk(top+1) * si l'element a creer est le dernier * lw est aussi mis a jour *---------------------------------------------------------- */ int C2F(listcreimat)(fname, lw, numi, stlw,it, m, n, lrs, fname_len) char *fname; integer *lw, *numi, *stlw, *m, *n, *lrs,*it; unsigned long fname_len; { integer ix1,il ; if (C2F(creimati)(fname, stlw,it, m, n, lrs, &c_true, fname_len)==FALSE_) return FALSE_ ; *stlw = sadr(*lrs + memused(*it,*m * *n)); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * creimat : * checks that an int matrix [it,m,n] can be stored at position lw * <> to real and imaginary part are returned on success * In : * lw : position (entier) * it : type 1,2,4,11,12,14 * m, n dimensions * Out : * lr : istk(lr+i-1)=> a(i) * Side effect : if matrix creation is possible * [it,m,n] are stored in Scilab stack * and lr is returned * but stk(lr+..) are unchanged *---------------------------------------------------------- */ int C2F(creimat)(fname, lw, it, m, n, lr, fname_len) char *fname; integer *lw, *it, *m, *n, *lr; unsigned long fname_len; { if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(creimati)(fname, Lstk(*lw ), it, m, n, lr,&c_true, fname_len) == FALSE_) return FALSE_ ; *Lstk(*lw +1) = sadr(*lr + memused(*it,*m * *n)); return TRUE_; } /*--------------------------------------------------------- * internal function used by cremat and listcremat *---------------------------------------------------------- */ int C2F(creimati)(fname, stlw, it, m, n, lr, flagx, fname_len) char *fname; integer *stlw, *it, *m, *n, *lr; int *flagx; unsigned long fname_len; { integer ix1; integer il; double size = memused(*it,((double)*m)*((double) *n)); il = iadr(*stlw); ix1 = il + 4; Err = sadr(ix1) - *Lstk(Bot ); if (Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; if (*flagx) { *istk(il ) = 8; /* if m*n=0 then both dimensions are to be set to zero */ *istk(il + 1) = Min(*m , *m * *n); *istk(il + 2) = Min(*n ,*m * *n); *istk(il + 3) = *it; } ix1 = il + 4; *lr = ix1; return TRUE_; } /********************************************************************** * BOOLEAN MATRICES **********************************************************************/ /*------------------------------------------------------------------ * getlistbmat : * checks that spos object is a list * checks that lnum-element of the list exists and is a boolean matrix * extracts matrix information(m,n,lr) *------------------------------------------------------------------ */ int C2F(getlistbmat)(fname, topk, spos, lnum, m, n, lr, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n, *lr; unsigned long fname_len; { integer nv; integer ili; if (C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len)== FALSE_) return FALSE_ ; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_ ; } return C2F(getbmati)(fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * getbmat : * check that object at position lw is a boolean matrix * In : * fname : name of calling function for error message * lw : stack position * Out : * [m,n] matrix dimensions * lr : istk(lr+i-1)= a(i) *------------------------------------------------------------------- */ int C2F(getbmat)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { return C2F(getbmati)(fname, topk, lw, Lstk(*lw ), m, n, lr, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------ * matbsize : * like getbmat but here m,n are given on entry * and we check that matrix is of size (m,n) *------------------------------------------------------------------ */ int C2F(matbsize)(fname, topk, lw, m, n, fname_len) char *fname; integer *topk, *lw, *m, *n; unsigned long fname_len; { integer m1, n1, lr; if ( C2F(getbmat)(fname, topk, lw, &m1, &n1, &lr, fname_len) == FALSE_) return FALSE_; if (*m != m1 || *n != n1) { Scierror(205,"%s: Argument %d, wrong matrix size (%d,%d) expected\r\n", get_fname(fname,fname_len),Rhs + (*lw - *topk),*m,*n); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(getbmati)(fname, topk, spos, lw, m, n, lr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n, *lr; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 4) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a boolean matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(208,"%s: argument %d should be a boolean matrix\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; }; *m = *istk(il +1); *n = *istk(il +2); *lr = il + 3; return TRUE_; } /*------------------------------------------------== * listcrebmat(top,numero,lw,....) * le numero ieme element de la liste en top doit etre un bmatrice * stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que stk(top+1) * si l'element a creer est le dernier * lw est aussi mis a jour *---------------------------------------------------------- */ int C2F(listcrebmat)(fname, lw, numi, stlw, m, n, lrs, fname_len) char *fname; integer *lw, *numi, *stlw, *m, *n, *lrs; unsigned long fname_len; { integer ix1; integer il; if ( C2F(crebmati)(fname, stlw, m, n, lrs, &c_true, fname_len)== FALSE_) return FALSE_; ix1 = *lrs + *m * *n + 2; *stlw = sadr(ix1); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * crebmat : * checks that a boolean matrix [m,n] can be stored at position lw * <> to data is returned on success * In : * lw : position (entier) * m, n dimensions * Out : * lr : istk(lr+i-1)= a(i) * Side effect : if matrix creation is possible * [m,n] are stored in Scilab stack * and lr is returned * but istk(lr+..) is unchanged *---------------------------------------------------------- */ int C2F(crebmat)(fname, lw, m, n, lr, fname_len) char *fname; integer *lw, *m, *n, *lr; unsigned long fname_len; { integer ix1; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_ ; } if ( C2F(crebmati)(fname, Lstk(*lw ), m, n, lr, &c_true, fname_len)== FALSE_) return FALSE_ ; ix1 = *lr + *m * *n + 2; *Lstk(*lw +1) = sadr(ix1); return TRUE_; } /*------------------------------------------------- * Similar to crebmat but we only check for space * no data is stored *-------------------------------------------------*/ int C2F(fakecrebmat)( lw, m, n, lr) integer *lw, *m, *n, *lr; { if (*lw + 1 >= Bot) { Scierror(18,"fakecrebmat: too many names\r\n"); return FALSE_; } if ( C2F(crebmati)("crebmat", Lstk(*lw ), m, n, lr, &c_false, 7L)== FALSE_) return FALSE_ ; *Lstk(*lw +1) = sadr( *lr + *m * *n + 2); return TRUE_; } /*--------------------------------------------------------- * internal function used by crebmat and listcrebmat *---------------------------------------------------------- */ int C2F(crebmati)(fname, stlw, m, n, lr, flagx, fname_len) char *fname; integer *stlw, *m, *n, *lr; int *flagx; unsigned long fname_len; { double size = ((double) *m) * ((double) *n) ; integer il; il = iadr(*stlw); Err = il + 3 - iadr(*Lstk(Bot )); if (Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; } if (*flagx) { *istk(il ) = 4; /* si m*n=0 les deux dimensions sont mises a zero. */ *istk(il + 1) = Min(*m , *m * *n); *istk(il + 2) = Min(*n,*m * *n); } *lr = il + 3; return TRUE_; } /********************************************************************** * SPARSE MATRICES * [it,m,n,nel,mnel,icol,lr,lc] * nel : number of non nul elements * istk(mnel+i-1), i=1,m : number of non nul elements of row i * non nul elements are stored in row order as follows: * istk(icol+j-1) ,j=1,nel, column of the j-th non null element * stk(lr + j-1) ,j=1,nel, real value of the j-th non null element * stk(lc + j-1) ,j=1,nel, imag. value of the j-th non null element * lc is to be used only if matrix is complex (it==1) **********************************************************************/ /*------------------------------------------------------------------ * getlistsparse : * checks that spos object is a list * checks that lnum-element of the list exists and is a sparse matrix * extracts matrix information(it,m,n,nel,mnel,icol,lr,lc) *------------------------------------------------------------------ */ int C2F(getlistsparse)(fname, topk, spos, lnum, it, m, n, nel, mnel, icol, lr, lc, fname_len) char *fname; integer *topk, *spos, *lnum, *it, *m, *n, *nel, *mnel, *icol, *lr, *lc; unsigned long fname_len; { integer nv; integer ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_ ; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getsparsei)(fname, topk, spos, &ili, it, m, n, nel, mnel, icol, lr, lc, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * getsparse : * check that object at position lw is a sparse matrix * In : * fname : name of calling function for error message * lw : stack position * Out : * [it,m,n,nel,mnel,icol,lr,lc] matrix dimensions *------------------------------------------------------------------- */ int C2F(getsparse)(fname, topk, lw, it, m, n, nel, mnel, icol, lr, lc, fname_len) char *fname; integer *topk, *lw, *it, *m, *n, *nel, *mnel, *icol, *lr, *lc; unsigned long fname_len; { return C2F(getsparsei)(fname, topk, lw, Lstk(*lw ), it, m, n, nel, mnel, icol, lr, lc, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------- * getrsparse : lie getsparse but we check for a real matrix *------------------------------------------------------------------- */ int C2F(getrsparse)(fname, topk, lw, m, n, nel, mnel, icol, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *nel, *mnel, *icol, *lr; unsigned long fname_len; { integer lc, it; if ( C2F(getsparse)(fname, topk, lw, &it, m, n, nel, mnel, icol, lr, &lc, fname_len) == FALSE_ ) return FALSE_; if (it != 0) { Scierror(202,"%s: Argument %d: wrong type argument expecting a real matrix\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; } return TRUE_; } /*--------------------------------------- * internal function for getmat and listgetmat *--------------------------------------- */ int C2F(getsparsei)(fname, topk, spos, lw, it, m, n, nel, mnel, icol, lr, lc, inlistx, nellist, fname_len) char *fname; integer *topk, *spos, *lw, *it, *m, *n, *nel, *mnel, *icol, *lr, *lc; int *inlistx; integer *nellist; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 5) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a sparse matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nellist); else Scierror(999,"%s: argument %d should be a sparse matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); *it = *istk(il + 3); *nel = *istk(il + 4); *mnel = il + 5; *icol = il + 5 + *m; *lr = sadr(il + 5 + *m + *nel); if (*it == 1) *lc = *lr + *nel; return TRUE_; } /*---------------------------------------------------------- * le numero ieme element de la liste en top doit etre une matrice * sparse stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que stk(top+1) * si l'element a creer est le dernier * lw est aussi mis a jour * *---------------------------------------------------------- */ int C2F(listcresparse)(fname, lw, numi, stlw, it, m, n, nel, mnel, icol, lrs, lcs, fname_len) char *fname; integer *lw, *numi, *stlw, *it, *m, *n, *nel, *mnel, *icol, *lrs, *lcs; unsigned long fname_len; { integer ix1,il; if (C2F(cresparsei)(fname, stlw, it, m, n, nel, mnel, icol, lrs, lcs, fname_len)== FALSE_) return FALSE_ ; *stlw = *lrs + *nel * (*it + 1); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) { *Lstk(*lw +1) = *stlw; } return TRUE_; } /*---------------------------------------------------------- * cresparse : * checks that a sparse matrix [it,m,n,nel,mnel,icol] can be stored at position lw * <> to real and imaginary part are returned on success * In : * lw : position (entier) * it : type 0 ou 1 * m, n,nel dimensions * Out : * mnel,icol,lr,lc * Side effect : if matrix creation is possible * [it,m,n,nel] are stored in Scilab stack * and mnel,icol,lr and lc are returned * but data is unchanged *---------------------------------------------------------- */ int C2F(cresparse)(fname, lw, it, m, n, nel, mnel, icol, lr, lc, fname_len) char *fname; integer *lw, *it, *m, *n, *nel, *mnel, *icol, *lr, *lc; unsigned long fname_len; { if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_ ; } if ( C2F(cresparsei)(fname, Lstk(*lw ), it, m, n, nel, mnel, icol, lr, lc, fname_len) == FALSE_) return FALSE_ ; *Lstk(*lw +1) = *lr + *nel * (*it + 1); return TRUE_; } /*--------------------------------------------------------- * internal function used by cremat and listcremat *---------------------------------------------------------- */ int C2F(cresparsei)(fname, stlw, it, m, n, nel, mnel, icol, lr, lc, fname_len) char *fname; integer *stlw, *it, *m, *n, *nel, *mnel, *icol, *lr, *lc; unsigned long fname_len; { integer il,ix1; il = iadr(*stlw); ix1 = il + 5 + *m + *nel; Err = sadr(ix1) + *nel * (*it + 1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; *istk(il ) = 5; /* if m*n=0 the 2 dims are set to zero */ if ( *m == 0 || *n == 0 ) /* use this new test in place of the product m * n (bruno) */ { *istk(il + 1) = 0; *istk(il + 2) = 0; } else { *istk(il + 1) = *m; *istk(il + 2) = *n; } *istk(il + 3) = *it; *istk(il + 4) = *nel; *mnel = il + 5; *icol = il + 5 + *m; ix1 = il + 5 + *m + *nel; *lr = sadr(ix1); *lc = *lr + *nel; return TRUE_; } /********************************************************************** * VECTORS **********************************************************************/ /*------------------------------------------------------------------ * getlistvect : * checks that spos object is a list * checks that lnum-element of the list exists and is a vector * extracts vector information(it,m,n,lr,lc) *------------------------------------------------------------------ */ int C2F(getlistvect)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *lnum, *it, *m, *n, *lr, *lc; unsigned long fname_len; { if (C2F(getlistmat)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len)== FALSE_) return FALSE_; if (*m != 1 && *n != 1) { Scierror(999,"%s: argument %d >(%d) should be a vector \r\n", get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------- * getvect : * check that object at position lw is a vector * In : * fname : name of calling function for error message * lw : stack position * Out : * [it,m,n] matrix dimensions * lr : stk(lr+i-1)= real(a(i)) * lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 *------------------------------------------------------------------- */ int C2F(getvect)(fname, topk, lw, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *lw, *it, *m, *n, *lr, *lc; unsigned long fname_len; { if ( C2F(getmat)(fname, topk, lw, it, m, n, lr, lc, fname_len) == FALSE_) return FALSE_; if (*m != 1 && *n != 1) { Scierror(214,"%s: Argument %d: wrong type argument expecting a vector\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; }; return TRUE_; } /*------------------------------------------------------------------ * getrvect : like getvect but we expect a real vector *------------------------------------------------------------------ */ int C2F(getrvect)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { if ( C2F(getrmat)(fname, topk, lw, m, n, lr, fname_len) == FALSE_) return FALSE_; if (*m != 1 && *n != 1) { Scierror(203,"%s: Argument %d: wrong type argument expecting a real vector\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; } return TRUE_ ; } /*------------------------------------------------------------------ * vectsize : * like getvect but here n is given on entry * and we check that vector is of size (n) *------------------------------------------------------------------ */ int C2F(vectsize)(fname, topk, lw, n, fname_len) char *fname; integer *topk, *lw, *n; unsigned long fname_len; { integer m1, n1, lc, lr, it1; if ( C2F(getvect)(fname, topk, lw, &it1, &m1, &n1, &lr, &lc, fname_len) == FALSE_) return FALSE_; if (*n != m1 * n1) { Scierror(206,"%s: Argument %d wrong vector size (%d) expected\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk), *n); return FALSE_; } return TRUE_; } /********************************************************************** * SCALAR **********************************************************************/ /*------------------------------------------------------------------ * getlistscalar : recupere un scalaire *------------------------------------------------------------------ */ int C2F(getlistscalar)(fname, topk, spos, lnum, lr, fname_len) char *fname; integer *topk, *spos, *lnum, *lr; unsigned long fname_len; { integer m, n; integer lc, it, nv; integer ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } if ( C2F(getmati)(fname, topk, spos, &ili, &it, &m, &n, lr, &lc, &c_true, lnum, fname_len) == FALSE_) return FALSE_; if (m * n != 1) { Scierror(999,"%s: argument %d > (%d) should be a scalar\r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------ * getscalar : * check that object at position lw is a scalar * In : * fname : name of calling function for error message * lw : stack position * Out : * lr : stk(lr)= scalar_value *------------------------------------------------------------------ */ int C2F(getscalar)(fname, topk, lw, lr, fname_len) char *fname; integer *topk, *lw, *lr; unsigned long fname_len; { integer m, n; if ( C2F(getrmat)(fname, topk, lw, &m, &n, lr, fname_len) == FALSE_) return FALSE_; if (m * n != 1) { Scierror(204,"%s: Argument %d: wrong wrong type argument expecting a scalar\r\n", get_fname(fname,fname_len),Rhs + (*lw - *topk)); return FALSE_ ; }; return TRUE_; } /********************************************************************** * STRING and string Matrices **********************************************************************/ /*------------------------------------------------------------------ * getlistsmat : * checks that spos object is a list * checks that lnum-element of the list exists and is a string matrix * extracts string matrix information in m,n and (ix,j)-th string in lr nlr * In : * fname : name of calling function for error message * topk : stack ref for error message * spos : stack position * lnum : element position in the list * ix,j : indices of the requested element * Out : * [m,n] : lnum smatrix dimensions * lr : istk(lr+i-1) gives string(ix,j) interbal codes * nlr : length of (ix,j)-th string *------------------------------------------------------------------ */ int C2F(getlistsmat)(fname, topk, spos, lnum, m,n , ix, j, lr, nlr, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n,*ix,*j, *lr, *nlr ; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getsmati)(fname, topk, spos, &ili, m, n, ix,j, lr, nlr, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * getsmat : * check that object at position lw is a string matrix * In : * fname : name of calling function for error message * lw : stack position * (ix,j): indices of the string element requested * Out : * [m,n] matrix dimensions * lr : istk(lr+i-1) gives string(ix,j) internal codes * nlr : length of (ix,j)-th string * Note : getsmat can be used to get a(1,1) and check that a is a string matrix * then other elements can be accessed through getsimat *------------------------------------------------------------------- */ int C2F(getsmat)(fname, topk, lw, m, n, ix, j, lr, nlr, fname_len) char *fname; integer *topk, *lw, *m, *n, *ix, *j, *lr, *nlr; unsigned long fname_len; { return C2F(getsmati)(fname, topk, lw, Lstk(*lw), m, n, ix,j , lr ,nlr, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------ * getsimat : * In : * fname : name of calling function for error message * lw : stack position * (ix,j): indices of the string element requested * Out : * [m,n] matrix dimensions * lr : istk(lr+i-1) gives string(ix,j) internal codes * nlr : length of (ix,j)-th string * Note : like getsmat but do not check that object is a string matrix *------------------------------------------------------------------- */ int C2F(getsimat)(fname, topk, lw, m, n, ix, j, lr, nlr, fname_len) char *fname; integer *topk, *lw, *m, *n, *ix, *j, *lr, *nlr; unsigned long fname_len; { return C2F(getsimati)(fname, topk, lw, Lstk(*lw), m, n, ix,j , lr ,nlr, &c_false, &cx0, fname_len); } /*-------------------------------------------------------------------------- * getlistwsmat : * similar to getlistsmat but returned values are different * ilr : * ilrd : * ilr and ilrd : internal coded versions of the strings * which can be converted to C with ScilabMStr2CM (see stack2.c) *------------------------------------------------------------------ */ int C2F(getlistwsmat)(fname, topk, spos, lnum, m, n, ilr, ilrd, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n, *ilr, *ilrd; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getwsmati)(fname, topk, spos, &ili, m, n, ilr, ilrd, &c_true, lnum, fname_len); } /*-------------------------------------------------------------------------- * getwsmat : checks for a mxn string matrix * similar to getsmat but returned values are different * ilr and ilrd : internal coded versions of the strings * which can be converted to C with ScilabMStr2CM (see stack2.c) *--------------------------------------------------------------------------*/ int C2F(getwsmat)(fname, topk, lw, m, n, ilr, ilrd, fname_len) char *fname; integer *topk, *lw, *m, *n, *ilr, *ilrd; unsigned long fname_len; { return C2F(getwsmati)(fname, topk, lw,Lstk(*lw), m, n, ilr, ilrd, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ static int C2F(getwsmati)(fname, topk, spos, lw, m, n, ilr, ilrd , inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n, *ilr, *ilrd; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 10) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a matrix of strings\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(207,"%s: Argument %d : wrong type argument, expecting a matrix of strings\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); *ilrd = il + 4; *ilr = il + 5 + *m * *n; return TRUE_; } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(getsmati)(fname, topk, spos, lw, m, n, ix,j , lr ,nlr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n, *ix,*j,*lr,*nlr; int *inlistx, *nel; unsigned long fname_len; { integer il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 10 ) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a string matrix\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(201,"%s: argument %d should be a string matrix\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } C2F(getsimati)(fname, topk, spos, lw, m, n, ix,j , lr ,nlr, inlistx, nel, fname_len); return TRUE_; } int C2F(getsimati)(fname, topk, spos, lw, m, n, ix,j , lr ,nlr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n,*ix,*j,*lr,*nlr; int *inlistx; integer *nel; unsigned long fname_len; { integer k, il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); *m = *istk(il + 1); *n = *istk(il + 2); k = *ix - 1 + (*j - 1) * *m; *lr = il + 4 + *m * *n + *istk(il + 4 + k ); *nlr = *istk(il + 4 + k +1) - *istk(il + 4 + k ); return 0; } /*---------------------------------------------------------- * listcresmat(top,numero,lw,....) * le ieme element de la liste en top doit etre une * matrice stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que Lstk(top+1) si l'element a creer est le dernier * lw est aussi mis a jour * job==1: nchar est la taille de chaque chaine de la matrice * job==2: nchar est le vecteur des tailles des chaines de la * matrice * job==3: nchar est le vecteur des pointeurs sur les chaines * de la matrice *---------------------------------------------------------- */ int C2F(listcresmat)(fname, lw, numi, stlw, m, n, nchar, job, ilrs, fname_len) char *fname; integer *lw, *numi, *stlw, *m, *n, *nchar, *job, *ilrs; unsigned long fname_len; { integer ix1; integer il, sz; if ( C2F(cresmati)(fname, stlw, m, n, nchar, job, ilrs, &sz, fname_len) == FALSE_ ) return FALSE_; ix1 = *ilrs + sz; *stlw = sadr(ix1); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * cresmat : * checks that a string matrix [m,n] of strings * (each string is of length nchar) * can be stored at position lw on the stack * Note that each string can be filled with getsimat *---------------------------------------------------------- */ int C2F(cresmat)(fname, lw, m, n, nchar, fname_len) char *fname; integer *lw, *m, *n, *nchar; unsigned long fname_len; { int job = 1; integer ix1, ilast, sz,lr ; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(cresmati)(fname,Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE_ ) return FALSE_ ; ilast = lr - 1; ix1 = ilast + *istk(ilast ); *Lstk(*lw +1) = sadr(ix1); /* empty strings */ if ( *nchar == 0) *Lstk(*lw +1) += 1; return TRUE_; } /*------------------------------------------------------------------ * cresmat1 : * checks that a string matrix [m,1] of string of length nchar[i] * can be stored at position lw on the stack * nchar : array of length m giving each string length * Note that each string can be filled with getsimat *------------------------------------------------------------------ */ int C2F(cresmat1)(fname, lw, m, nchar, fname_len) char *fname; integer *lw, *m, *nchar; unsigned long fname_len; { int job = 2, n=1; integer ix1, ilast, sz,lr ; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(cresmati)(fname,Lstk(*lw), m, &n, nchar, &job, &lr, &sz, fname_len) == FALSE_ ) return FALSE_ ; ilast = lr - 1; ix1 = ilast + *istk(ilast ); *Lstk(*lw +1) = sadr(ix1); return TRUE_; } /*------------------------------------------------------------------ * cresmat2 : * checks that a string of length nchar can be stored at position lw * Out : * lr : istk(lr+i) give access to the internal array * allocated for string code *------------------------------------------------------------------ */ int C2F(cresmat2)(fname, lw, nchar, lr, fname_len) char *fname; integer *lw, *nchar, *lr; unsigned long fname_len; { int job = 1, n=1,m=1; integer ix1, ilast, sz ; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(cresmati)(fname,Lstk(*lw), &m, &n, nchar, &job, lr, &sz, fname_len) == FALSE_ ) return FALSE_ ; ilast = *lr - 1; ix1 = ilast + *istk(ilast ); *Lstk(*lw +1) = sadr(ix1); /* empty strings */ if ( *nchar == 0) *Lstk(*lw +1) += 1; *lr = ilast + *istk(ilast - 1); return TRUE_; } /*------------------------------------------------------------------ * cresmat3 : * Try to create a string matrix S of size mxn * - nchar: array of size mxn giving the length of string S(i,j) * - buffer : a character array wich contains the concatenation * of all the strings * - lw : stack position for string creation *------------------------------------------------------------------ */ int C2F(cresmat3)(fname, lw, m, n, nchar, buffer, fname_len, buffer_len) char *fname; integer *lw, *m, *n, *nchar; char *buffer; unsigned long fname_len; unsigned long buffer_len; { int job = 2; integer ix1, ilast, sz,lr,lr1 ; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(cresmati)(fname,Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE_ ) return FALSE_ ; ilast = lr - 1; ix1 = ilast + *istk(ilast ); *Lstk(*lw +1) = sadr(ix1); lr1 = ilast + *istk(ilast - (*m)*(*n) ); C2F(cvstr)(&sz, istk(lr1), buffer, &cx0, buffer_len); return TRUE_; } /*------------------------------------------------------------------ * checks that an [m,1] string matrix can be stored in the * stack. * All chains have the same length nchar * istk(lr) --- beginning of chains *------------------------------------------------------------------ */ int C2F(cresmat4)(fname, lw, m, nchar, lr, fname_len) char *fname; integer *lw, *m, *nchar, *lr; unsigned long fname_len; { integer ix1,ix, ilast, il, nnchar, kij, ilp; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } nnchar = 0; ix1 = *m; for (ix = 1; ix <= ix1; ++ix) nnchar += *nchar; il = iadr(*Lstk(*lw )); ix1 = il + 4 + (nnchar + 1) * *m; Err = sadr(ix1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; } *istk(il ) = 10; *istk(il + 1) = *m; *istk(il + 2) = 1; *istk(il + 3) = 0; ilp = il + 4; *istk(ilp ) = 1; ix1 = ilp + *m; for (kij = ilp + 1; kij <= ix1; ++kij) { *istk(kij ) = *istk(kij - 1) + *nchar; } ilast = ilp + *m; ix1 = ilast + *istk(ilast ); *Lstk(*lw +1) = sadr(ix1); *lr = ilast + 1; return TRUE_; } /*--------------------------------------------------------- * internal function used by cresmat cresmat1 and listcresmat * job : * case 1: all string are of same length (nchar) in the matrix * case 2: nchar is a vector which gives string lengthes * case 3: ? *---------------------------------------------------------- */ int C2F(cresmati)(fname, stlw, m, n, nchar, job, lr, sz, fname_len) char *fname; integer *stlw, *m, *n, *nchar, *job, *lr, *sz; unsigned long fname_len; { integer ix1, ix, il, kij, ilp, mn= (*m)*(*n); il = iadr(*stlw); /* compute the size of chains */ *sz = 0; switch ( *job ) { case 1 : *sz = mn * nchar[0]; break; case 2 : for (ix = 0 ; ix < mn ; ++ix) *sz += nchar[ix]; break; case 3 : *sz = nchar[mn] - 1; break; } /* check the stack for space */ ix1 = il + 4 + mn + 1 + *sz; Err = sadr(ix1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; }; *istk(il ) = 10; *istk(il + 1) = *m; *istk(il + 2) = *n; *istk(il + 3) = 0; ilp = il + 4; *istk(ilp ) = 1; switch ( *job ) { case 1 : ix1 = mn + ilp; for (kij = ilp + 1; kij <= ix1; ++kij) { *istk(kij) = *istk(kij - 1) + nchar[0]; } break; case 2 : ix = 0; ix1 = mn + ilp; for (kij = ilp + 1; kij <= ix1; ++kij) { *istk(kij ) = *istk(kij - 2 +1) + nchar[ix]; ++ix; } break; case 3 : { int ix1 = mn + 1; C2F(icopy)(&ix1, nchar, &cx1, istk(ilp ), &cx1); } } *lr = ilp + mn + 1; return TRUE_; } /*------------------------------------------------------------------ * Try to create a string matrix S of size mxn * - m is the number of rows of Matrix S * - n is the number of colums of Matrix S * - Str : a null terminated array of strings char **Str assumed * to contain at least m*n strings * - lw : where to create the matrix on the stack *------------------------------------------------------------------ */ int cre_smat_from_str_i(fname, lw, m, n, Str, fname_len ,rep) char *fname; integer *lw, *m, *n; char *Str[]; unsigned long fname_len; integer *rep; { integer ix1, ix, ilast, il, nnchar, lr1, kij, ilp; integer *pos; nnchar = 0; for (ix = 0 ; ix < (*m)*(*n) ; ++ix) nnchar += strlen(Str[ix]); il = iadr(*lw); ix1 = il + 4 + (nnchar + 1) + (*m * *n + 1); Err = sadr(ix1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; } ; *istk(il ) = 10; *istk(il + 1) = *m; *istk(il + 2) = *n; *istk(il + 3) = 0; ilp = il + 4; *istk(ilp ) = 1; ix = 0; ix1 = ilp + *m * *n; for (kij = ilp + 1; kij <= ix1; ++kij) { *istk(kij ) = *istk(kij - 1) + strlen(Str[ix]); ++ix; } ilast = ilp + *m * *n; lr1 = ilast + *istk(ilp ); pos = istk(lr1); for ( ix = 0 ; ix < (*m)*(*n) ; ix++) { int l = strlen(Str[ix]); C2F(cvstr)(&l, pos, Str[ix], &cx0, l); pos += l; } ix1 = ilast + *istk(ilast ); *rep = sadr(ix1); return TRUE_; } int cre_smat_from_str(fname, lw, m, n, Str, fname_len ) char *fname; integer *lw, *m, *n; char *Str[]; unsigned long fname_len; { int rep; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( cre_smat_from_str_i(fname, Lstk(*lw ), m, n, Str, fname_len,&rep)== FALSE_ ) return FALSE_; *Lstk(*lw+1) = rep; return TRUE_; } int cre_listsmat_from_str(fname, lw, numi, stlw, m, n, Str, fname_len ) char *fname; integer *lw, *m, *n,*numi,*stlw; char *Str[]; unsigned long fname_len; { int rep,ix1,il; if ( cre_smat_from_str_i(fname, stlw, m, n, Str, fname_len,&rep)== FALSE_ ) return FALSE_; *stlw = rep; il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*------------------------------------------------------------------ * Try to create a sparse matrix S of size mxn * - m is the number of rows of Matrix S * - n is the number of colums of Matrix S * - Str : a null terminated array of strings char **Str assumed * to contain at least m*n strings * - lw : where to create the matrix on the stack *------------------------------------------------------------------ */ int cre_sparse_from_ptr_i(fname, lw, m, n, S, fname_len ,rep) char *fname; integer *lw, *m, *n; SciSparse *S; unsigned long fname_len; integer *rep; { double size = (double) ( (S->nel)*(S->it + 1) ); integer ix1, il, lr, lc; integer cx1=1; il = iadr(*lw); ix1 = il + 5 + *m + S->nel; Err = sadr(ix1) - *Lstk(Bot ); if (Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; } ; *istk(il ) = 5; /* note: code sligtly modified (remark of C. Deroulers in the newsgroup) */ if ( (*m == 0) | (*n == 0) ) { *istk(il + 1) = 0; *istk(il + 2) = 0; } else { *istk(il + 1) = *m; *istk(il + 2) = *n; } /* end of the modified code */ *istk(il + 3) = S->it; *istk(il + 4) = S->nel; C2F(icopy)(&S->m, S->mnel, &cx1, istk(il+5 ), &cx1); C2F(icopy)(&S->nel, S->icol, &cx1, istk(il+5+*m ), &cx1); ix1 = il + 5 + *m + S->nel; lr = sadr(ix1); lc = lr + S->nel; C2F(dcopy)(&S->nel, S->R, &cx1, stk(lr), &cx1); if ( S->it == 1) C2F(dcopy)(&S->nel, S->I, &cx1, stk(lc), &cx1); *rep = lr + S->nel*(S->it+1); return TRUE_; } int cre_sparse_from_ptr(fname, lw, m, n, Str, fname_len ) char *fname; integer *lw, *m, *n; SciSparse *Str; unsigned long fname_len; { int rep; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( cre_sparse_from_ptr_i(fname, Lstk(*lw ), m, n, Str, fname_len,&rep)== FALSE_ ) return FALSE_; *Lstk(*lw+1) = rep; return TRUE_; } int cre_listsparse_from_ptr(fname, lw, numi, stlw, m, n, Str, fname_len ) char *fname; integer *lw, *m, *n,*numi,*stlw; SciSparse *Str; unsigned long fname_len; { int rep,ix1,il; if ( cre_sparse_from_ptr_i(fname, stlw, m, n, Str, fname_len,&rep)== FALSE_ ) return FALSE_; *stlw = rep; il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*------------------------------------------------------------------ * XXXXXXXX : j'en suis la * listcrestring *------------------------------------------------------------------ */ int C2F(listcrestring)(fname, lw, numi, stlw, nch, ilrs, fname_len) char *fname; integer *lw, *numi, *stlw, *nch, *ilrs; unsigned long fname_len; { integer ix1, il ; if ( C2F(crestringi)(fname, stlw, nch, ilrs, fname_len) == FALSE_ ) return FALSE_; ix1 = *ilrs - 1 + *istk(*ilrs - 2 +1); *stlw = sadr(ix1); il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) { *Lstk(*lw +1) = *stlw; } return TRUE_; } /*------------------------------------------------------------------ * verifie que l'on peut stocker une matrice [1,1] * de chaine de caracteres a la position spos du stack * en renvoyant .true. ou .false. suivant la reponse. * nchar est le nombre de caracteres que l'on veut stocker * Entree : * spos : position (entier) * Sortie : * ilrs *------------------------------------------------------------------ */ int C2F(crestring)(fname, spos, nchar, ilrs, fname_len) char *fname; integer *spos, *nchar, *ilrs; unsigned long fname_len; { integer ix1; if ( C2F(crestringi)(fname, Lstk(*spos ), nchar, ilrs, fname_len) == FALSE_) return FALSE_; ix1 = *ilrs + *nchar; *Lstk(*spos +1) = sadr(ix1); /* empty strings */ if ( *nchar == 0) *Lstk(*spos +1) += 1; return TRUE_; } /*------------------------------------------------------------------ * verifie que l'on peut stocker une matrice [1,1] * de chaine de caracteres a la position stlw en renvoyant .true. ou .false. * suivant la reponse. * nchar est le nombre de caracteres que l'on veut stcoker * Entree : * stlw : position (entier) * Sortie : * nchar : nombre de caracteres stockable * lr : pointe sur a(1,1)=istk(lr) *------------------------------------------------------------------ */ int C2F(crestringi)(fname, stlw, nchar, ilrs, fname_len) char *fname; integer *stlw, *nchar, *ilrs; unsigned long fname_len; { integer ix1, ilast, il; il = iadr(*stlw); ix1 = il + 4 + (*nchar + 1); Err = sadr(ix1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; } ; *istk(il ) = 10; *istk(il +1) = 1; *istk(il + 1 +1) = 1; *istk(il + 2 +1) = 0; *istk(il + 3 +1) = 1; *istk(il + 4 +1) = *istk(il + 3 +1) + *nchar; ilast = il + 5; *ilrs = ilast + *istk(ilast - 2 +1); return TRUE_; } /*--------------------------------------------------------------------- * checks if we can store a string of size nchar at position lw *---------------------------------------------------------------------*/ int C2F(fakecresmat2)(lw, nchar, lr) integer *lw, *nchar, *lr; { static integer cx17 = 17; int retval; static integer ilast; static integer il; il = iadr((*Lstk(*lw))); Err = sadr(il + 4 + (*nchar + 1)) - *Lstk(Bot); if (Err > 0) { C2F(error)(&cx17); retval = FALSE_; } else { ilast = il + 5; *Lstk(*lw+1) = sadr(ilast + *istk(ilast)); *lr = ilast + *istk(ilast - 1); retval = TRUE_; } return retval; } /*------------------------------------------------------------------ * verifie qu'il y a une matrice de chaine de caracteres en lw-1 * et verifie que l'on peut stocker l'extraction de la jieme colonne * en lw : si oui l'extraction est faite * Entree : * lw : position (entier) * j : colonne a extraire *------------------------------------------------------------------ */ int C2F(smatj)(fname, lw, j, fname_len) char *fname; integer *lw, *j; unsigned long fname_len; { integer ix1, ix2; integer incj; integer ix, m, n; integer lj, nj, lr, il1, il2, nlj; integer il1j, il2p; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } ix1 = *lw - 1; ix2 = *lw - 1; if (! C2F(getsmat)(fname, &ix1, &ix2, &m, &n, &cx1, &cx1, &lr, &nlj, fname_len)) return FALSE_; if (*j > n) return FALSE_; il1 = iadr(*Lstk(*lw - 2 +1)); il2 = iadr(*Lstk(*lw )); /* nombre de caracteres de la jieme colonne */ incj = (*j - 1) * m; nj = *istk(il1 + 4 + incj + m ) - *istk(il1 + 4 + incj ); /* test de place */ ix1 = il2 + 4 + m + nj + 1; Err = sadr(ix1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; } *istk(il2 ) = 10; *istk(il2 +1) = m; *istk(il2 + 1 +1) = 1; *istk(il2 + 2 +1) = 0; il2p = il2 + 4; il1j = il1 + 4 + incj; *istk(il2p ) = 1; ix1 = m; for (ix = 1; ix <= ix1; ++ix) { *istk(il2p + ix ) = *istk(il2p - 1 + ix ) + *istk(il1j + ix ) - *istk(il1j + ix - 2 +1); } lj = *istk(il1 + 4 + incj ) + il1 + 4 + m * n; C2F(icopy)(&nj, istk(lj ), &cx1, istk(il2 + 4 + m +1), &cx1); ix1 = il2 + 4 + m + nj + 1; *Lstk(*lw +1) = sadr(ix1); return TRUE_; } /*------------------------------------------------------------------ * copie la matrice de chaine de caracteres stockee en flw * en tlw, les verifications de dimensions * ne sont pas faites * Lstk(tlw+1) est modifie si necessaire *------------------------------------------------------------------ */ int C2F(copysmat)(fname, flw, tlw, fname_len) char *fname; integer *flw, *tlw; unsigned long fname_len; { integer ix1; integer dflw, fflw; integer dtlw; dflw = iadr(*Lstk(*flw )); fflw = iadr(*Lstk(*flw +1)); dtlw = iadr(*Lstk(*tlw )); ix1 = fflw - dflw; C2F(icopy)(&ix1, istk(dflw ), &cx1, istk(dtlw ), &cx1); *Lstk(*tlw +1) = *Lstk(*tlw ) + *Lstk(*flw +1) - *Lstk(*flw ); return 0; } /*------------------------------------------------------------------ * lw designe une matrice de chaine de caracteres * on veut changer la taille de la chaine (i,j) * et lui donner la valeur nlr * cette routine si (i,j) != (m,n) fixe * le pointeur de l'argument i+j*m +1 * sans changer les valeurs de la matrice * si (i,j)=(m,n) fixe juste la longeur de la chaine * Entree : * fname : nom de la routine appellante pour le message * d'erreur * lw : position dans la pile * i,j : indice considere * m,n : taille de la matrice * lr : *------------------------------------------------------------------ */ int C2F(setsimat)(fname, lw, ix, j, nlr, fname_len) char *fname; integer *lw, *ix, *j, *nlr; unsigned long fname_len; { integer k, m, il; il = iadr(*Lstk(*lw )); m = *istk(il +1); k = *ix - 1 + (*j - 1) * m; *istk(il + 4 + k +1) = *istk(il + 4 + k ) + *nlr; return 0; } /********************************************************************** * LISTS **********************************************************************/ /*------------------------------------------------------------------- * crelist :creation of a list with ilen elements at slw position * cretlist:creation of a tlist with ilen elements at slw position * cremlist:creation of an mlist with ilen elements at slw position * In : slw and ilen * Out : lw * first element can be stored at postion stk(lw) * Note : elements are to be added to close the list creation *------------------------------------------------------------------- */ int crelist_G(slw, ilen, lw, type) integer *slw, *ilen, *lw, type; { integer ix1; integer il; il = iadr(*Lstk(*slw )); *istk(il ) = type; *istk(il + 1) = *ilen; *istk(il + 2) = 1; ix1 = il + *ilen + 3; *lw = sadr(ix1); if (*ilen == 0) *Lstk(*lw +1) = *lw; return 0; } int C2F(crelist)(slw, ilen, lw) integer *slw, *ilen, *lw; { return crelist_G(slw,ilen,lw,15); } int C2F(cretlist)(slw, ilen, lw) integer *slw, *ilen, *lw; { return crelist_G(slw,ilen,lw,16); } int C2F(cremlist)(slw, ilen, lw) integer *slw, *ilen, *lw; { return crelist_G(slw,ilen,lw,17); } /*------------------------------------------------------------------ * lmatj : * checks that there's a list at position lw-1 * checks that the j-th element can be extracted at lw position * perform the extraction * lw : position * j : element to be extracted *------------------------------------------------------------------ */ int C2F(lmatj)(fname, lw, j, fname_len) char *fname; integer *lw, *j; unsigned long fname_len; { integer ix1, ix2; integer n; integer il, ilj, slj; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } ix1 = *lw - 1; ix2 = *lw - 1; if (! C2F(getilist)(fname, &ix1, &ix2, &n, j, &ilj, fname_len)) return FALSE_; if (*j > n) return FALSE_; /* a ameliorer */ il = iadr(*Lstk(*lw - 2 +1)); ix1 = il + 3 + n; slj = sadr(ix1) + *istk(il + 2 + (*j - 1) ) - 1; n = *istk(il + 2 + *j ) - *istk(il + 2 + (*j - 1) ); Err = *Lstk(*lw ) + n - *Lstk(Bot ); if (Err > 0) return FALSE_; C2F(dcopy)(&n, stk(slj ), &cx1, stk(*Lstk(*lw ) ), &cx1); *Lstk(*lw +1) = *Lstk(*lw ) + n; return TRUE_; } /*------------------------------------------------ * renvoit .true. si l'argument en lw est une liste * Entree : * fname : nom de la routine appellante pour le message * d'erreur * lw : position ds la pile * i : element demande * Sortie : * n : nombre d'elements ds la liste * ili : le ieme element commence en istk(iadr(ili)) * ==> pour recuperer un argument il suffit * de faire un lk=Lstk(top);Lstk(top)=ili; getmat(...,top,...);stk(top)=lk *------------------------------------------------*/ int C2F(getilist)(fname, topk, lw, n, ix, ili, fname_len) char *fname; integer *topk, *lw, *n, *ix, *ili; unsigned long fname_len; { integer ix1; integer itype, il; il = iadr(*Lstk(*lw )); if (*istk(il ) < 0) { il = iadr(*istk(il +1)); } itype = *istk(il ); if (itype < 15 || itype > 17) { Scierror(210,"%s: Argument %d: wrong type argument, expecting a list\r\n", get_fname(fname,fname_len) , Rhs + (*lw - *topk)); return FALSE_; } *n = *istk(il +1); if (*ix <= *n) { ix1 = il + 3 + *n; *ili = sadr(ix1) + *istk(il + 2 + (*ix - 1) ) - 1; } else { *ili = 0; } return TRUE_; } /********************************************************************** * POLYNOMS **********************************************************************/ /*------------------------------------------------ * renvoit .true. si l'argument en lw est une matrice de polynome * sinon appelle error et renvoit .false. * Entree : * fname : nom de la routine appellante pour le message * d'erreur * lw : position ds la pile * Sortie * [it,m,n] caracteristiques de la matrice * name : nom de la variable muette ( character*4) * namel : taille de name <=4 ( uncounting trailling blanks) * soit lij=istk(ilp+(i-1)+(j-1)*m) * alors le degre zero de l'elements (i,j) est en * stk(lr+lij) (partie reelle ) et stk(lc+lij) (imag) * le degre de l'elt (i,j)= l(i+1)j - lij -1 * implicit undefined (a-z) *------------------------------------------------*/ int C2F(getpoly)(fname, topk, lw, it, m, n, namex, namel, ilp, lr, lc, fname_len, name_len) char *fname; integer *topk, *lw, *it, *m, *n; char *namex; integer *namel, *ilp, *lr, *lc; unsigned long fname_len; unsigned long name_len; { integer ix1; integer il; il = iadr(*Lstk(*lw )); if (*istk(il ) != 2) { Scierror(212,"%s: Argument %d: wrong type argument, expecting a polynomial matrix\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); return FALSE_; } ; *m = *istk(il +1); *n = *istk(il +2); *it = *istk(il + 3); *namel = 4; C2F(cvstr)(namel, istk(il + 4), namex, &cx1, 4L); L11: if (*namel > 0) { if ( namex[*namel - 1] == ' ') { --(*namel); goto L11; } } *ilp = il + 8; ix1 = *ilp + *m * *n + 1; *lr = sadr(ix1) - 1; *lc = *lr + *istk(*ilp + *m * *n ) - 1; return TRUE_; } /*------------------------------------------------------------------ * recupere un polynome * md est son degre et son premier element est en * stk(lr),stk(lc) * Finir les tests *------------------------------------------------------------------ */ int C2F(getonepoly)(fname, topk, lw, it, md, namex, namel, lr, lc, fname_len, name_len) char *fname; integer *topk, *lw, *it, *md; char *namex; integer *namel, *lr, *lc; unsigned long fname_len; unsigned long name_len; { integer m, n; integer ilp; if (C2F(getpoly)(fname, topk, lw, it, &m, &n, namex, namel, &ilp, lr, lc, fname_len, 4L) == FALSE_) return FALSE_; if (m * n != 1) { Scierror(998,"%s: argument should be a polygon\r\n", get_fname(fname,fname_len)); return FALSE_; } *md = *istk(ilp +1) - *istk(ilp ) - 1; *lr += *istk(ilp ); *lc += *istk(ilp ); return TRUE_; } /*------------------------------------------------------------------ * pmatj : * checks that there's a polynomial matrix at position lw-1 * checks that the j-th column can be extracted at lw position * perform the extraction * lw : position * j : column to be extracted *------------------------------------------------------------------ */ int C2F(pmatj)(fname, lw, j, fname_len) char *fname; integer *lw, *j; unsigned long fname_len; { integer ix1, ix2; char namex[4]; integer incj; integer ix, l, m, n, namel; integer l2, m2, n2, lc, il, lj, it, lr, il2, ilp; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } ix1 = *lw - 1; ix2 = *lw - 1; if (! C2F(getpoly)(fname, &ix1, &ix2, &it, &m, &n, namex, &namel, &ilp, &lr, &lc, fname_len, 4L)) { return FALSE_; } if (*j > n) return FALSE_; /* a ameliorer */ il = iadr(*Lstk(*lw - 2 +1)); incj = (*j - 1) * m; il2 = iadr(*Lstk(*lw )); ix1 = il2 + 4; l2 = sadr(ix1); m2 = Max(m,1); ix1 = il + 9 + m * n; l = sadr(ix1); n = *istk(il + 8 + m * n ); ix1 = il2 + 9 + m2; l2 = sadr(ix1); n2 = *istk(il + 8 + incj + m ) - *istk(il + 8 + incj ); Err = l2 + n2 * (it + 1) - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; } C2F(icopy)(&cx4, istk(il + 3 +1), &cx1, istk(il2 + 3 +1), &cx1); il2 += 8; il = il + 8 + incj; lj = l - 1 + *istk(il ); *istk(il2 ) = 1; ix1 = m2; for (ix = 1; ix <= ix1; ++ix) { *istk(il2 + ix ) = *istk(il2 - 1 + ix ) + *istk(il + ix ) - *istk(il - 1 + ix ); } C2F(dcopy)(&n2, stk(lj ), &cx1, stk(l2 ), &cx1); if (it == 1) { C2F(dcopy)(&n2, stk(lj + n ), &cx1, stk(l2 + n2 ), &cx1); } *Lstk(Top +1) = l2 + n2 * (it + 1); il2 += -8; *istk(il2 ) = 2; *istk(il2 +1) = m2; *istk(il2 + 1 +1) = 1; *istk(il2 + 2 +1) = it; return TRUE_; } /********************************************************************** * WORKING ARRAYS **********************************************************************/ /*------------------------------------------------------------------ * crewmat : uses the rest of the stack as a working area (double) * In : * lw : position (entier) * Out: * m : size that can be used * lr : stk(lr+i) is the working area *------------------------------------------------------------------ */ int C2F(crewmat)(fname, lw, m, lr, fname_len) char *fname; integer *lw, *m, *lr; unsigned long fname_len; { integer il,ix1; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } il = iadr(*Lstk(*lw )); *m = *Lstk(Bot ) - sadr(il+4); *istk(il ) = 1; *istk(il + 1) = 1; *istk(il + 2) = *m; *istk(il + 3) = 0; ix1 = il + 4; *lr = sadr(il+4); *Lstk(*lw +1) = sadr(il+4) + *m; return TRUE_; } /*------------------------------------------------------------------ * crewimat : uses the rest of the stack as a working area (int) * In : * lw : position (entier) * Out: * m : size that can be used * lr : istk(lr+i) is the working area *------------------------------------------------------------------ */ int C2F(crewimat)(fname, lw, m, n, lr, fname_len) char *fname; integer *lw, *m, *n, *lr; unsigned long fname_len; { double size = ((double) *m) * ((double) *n ); integer ix1,il; if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } il = iadr(*Lstk(*lw )); Err = il + 3 - iadr(*Lstk(Bot )); if (Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; } *istk(il ) = 4; *istk(il + 1) = *m; *istk(il + 2) = *n; *lr = il + 3; ix1 = il + 3 + *m * *n + 2; *Lstk(*lw +1) = sadr(ix1); return TRUE_; } /*------------------------------------------------ * getwimat : used to get information about * a working area set by crewimat * In : * fname, topk, lw * Out : * m, n : dimensions * lr : working area is istk(lr+i) i=0,m*n-1 *------------------------------------------------ */ int C2F(getwimat)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { integer il; il = iadr(*Lstk(*lw )); if (*istk(il ) < 0) { il = iadr(*istk(il +1)); } if (*istk(il ) != 4) { Scierror(213,"%s: Argument %d: wrong type argument, expecting a working\r\n\tinteger matrix\r\n", get_fname(fname,fname_len),Rhs + (*lw - *topk)); return FALSE_; }; *m = *istk(il + 1); *n = *istk(il + 2); *lr = il + 3; return TRUE_; } /*------------------------------------------------------------------ * creation of an object of type pointer at spos position on the stack * the pointer points to an object of type char matrix created by * the c routine stringc and is filled with a scilab stringmat * which was stored at istk(ilorig) * stk(lw) is used to transmit the pointer * F: transforme une stringmat scilab en un objet de type * pointeur qui pointe vers une traduction en C de la stringMat *------------------------------------------------------------------- */ int C2F(crestringv)(fname, spos, ilorig, lw, fname_len) char *fname; integer *spos, *ilorig, *lw; unsigned long fname_len; { integer ierr; if (C2F(crepointer)(fname, spos, lw, fname_len) == FALSE_) return FALSE_; C2F(stringc)(istk(*ilorig ), (char ***)stk(*lw ), &ierr); if (ierr != 0) { Scierror(999,"Not enough memory\r\n"); return FALSE_; } return TRUE_; } /*---------------------------------------------------------- * listcrepointer(top,numero,lw,....) *---------------------------------------------------------- */ int C2F(listcrepointer)(fname, lw, numi, stlw, lrs, fname_len) char *fname; integer *lw, *numi, *stlw, *lrs; unsigned long fname_len; { integer ix1,il ; if (C2F(crepointeri)(fname, stlw, lrs, &c_true, fname_len)==FALSE_) return FALSE_ ; *stlw = *lrs + 2; il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * crepointer : *---------------------------------------------------------- */ int C2F(crepointer)(fname, lw, lr, fname_len) char *fname; integer *lw, *lr; unsigned long fname_len; { if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(crepointeri)(fname, Lstk(*lw ), lr, &c_true, fname_len) == FALSE_) return FALSE_ ; *Lstk(*lw +1) = *lr + 2; return TRUE_; } /*--------------------------------------------------------- * internal function used by crepointer and listcrepointer *---------------------------------------------------------- */ int C2F(crepointeri)(fname, stlw, lr, flagx, fname_len) char *fname; integer *stlw, *lr; int *flagx; unsigned long fname_len; { integer ix1; integer il; il = iadr(*stlw); ix1 = il + 4; Err = sadr(ix1) + 2 - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; if (*flagx) { *istk(il ) = 128; /* if m*n=0 then both dimensions are to be set to zero */ *istk(il + 1) = 1; *istk(il + 2) = 1; *istk(il + 3) = 0; } ix1 = il + 4; *lr = sadr(ix1); return TRUE_; } /*------------------------------------------------------------------- * creates a Scilab stringpointer on the stack at position spos * of size mxn the stringpointer is filled with the datas stored * in stk(lorig) ( for example created with cstringv ) * and the data stored at stk(lorig) is freed *------------------------------------------------------------------- */ int C2F(lcrestringmatfromc)(fname, spos, numi, stlw, lorig, m, n, fname_len) char *fname; integer *spos, *numi, *stlw, *lorig, *m, *n; unsigned long fname_len; { integer ix1; integer ierr; integer il, ilw; ilw = iadr(*stlw); ix1 = *Lstk(Bot ) - *stlw; C2F(cstringf)((char ***)stk(*lorig ), istk(ilw ), m, n, &ix1, &ierr); if (ierr > 0) { Scierror(999,"Not enough memory\r\n"); return FALSE_; } ix1 = ilw + 5 + *m * *n + *istk(ilw + 4 + *m * *n ) - 1; *stlw = sadr(ix1); il = iadr(*Lstk(*spos )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) { *Lstk(*spos +1) = *stlw; } return TRUE_; } /*------------------------------------------------------------------- * creates a Scilab stringmat on the stack at position spos * of size mxn the stringmat is filled with the datas stored * in stk(lorig) ( for example created with cstringv ) * and the data stored at stk(lorig) is freed *------------------------------------------------------------------- */ int C2F(crestringmatfromc)(fname, spos, lorig, m, n, fname_len) char *fname; integer *spos, *lorig, *m, *n; unsigned long fname_len; { integer ix1; integer ierr; integer ilw; ilw = iadr(*Lstk(*spos )); ix1 = *Lstk(Bot ) - *Lstk(*spos ); C2F(cstringf)((char ***)stk(*lorig ), istk(ilw ), m, n, &ix1, &ierr); if (ierr > 0) { Scierror(999,"Not enough memory\r\n"); return FALSE_; } ix1 = ilw + 5 + *m * *n + *istk(ilw + 4 + *m * *n ) - 1; *Lstk(*spos +1) = sadr(ix1); return TRUE_; } /*------------------------------------------------------------------ * getlistvectrow : recupere un vecteur ligne dans une liste *------------------------------------------------------------------ */ int C2F(getlistvectrow)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *lnum, *it, *m, *n, *lr, *lc; unsigned long fname_len; { integer nv; integer ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } if (C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len)== FALSE_) return FALSE_; if (*m != 1) { Scierror(999,"%s: argument %d >(%d) should be a row vector \r\n", get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------ * Fonction normalement identique a getmat mais rajoutee * pour ne pas avoir a changer le stack.f de interf * renvoit .true. si l'argument en spos est une matrice * sinon appelle error et renvoit .false. * Entree : * fname : nom de la routine appellante pour le message * d'erreur * spos : position ds la pile * Sortie * [it,m,n] caracteristiques de la matrice * lr : pointe sur la partie reelle ( si la matrice est a * a(1,1)=stk(lr) * si l'on veut acceder a des entiers * a(1,1)=istk(adr(lr,0)) * lc : pointe sur la partie imaginaire si elle existe sinon sur zero *------------------------------------------------------------------ */ int C2F(getvectrow)(fname, topk, spos, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *it, *m, *n, *lr, *lc; unsigned long fname_len; { if (C2F(getmati)(fname, topk, spos, Lstk(*spos ), it, m, n, lr, lc, &c_false, &cx0, fname_len) == FALSE_) return FALSE_; if (*m != 1) { Scierror(999,"%s: argument %d should be a row vector \r\n", get_fname(fname,fname_len),Rhs + (*spos - *topk)); return FALSE_; } return TRUE_ ; } /*------------------------------------------------------------------ * *------------------------------------------------------------------ */ int C2F(getlistvectcol)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *lnum, *it, *m, *n, *lr, *lc; unsigned long fname_len; { integer nv; integer ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } if ( C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len) == FALSE_) return FALSE_; if (*n != 1) { Scierror(999,"%s: argument %d >(%d) should be a column vector \r\n", get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum); return FALSE_; } return TRUE_; } /*------------------------------------------------------------------ * Fonction normalement identique a getmat mais rajoutee * pour ne pas avoir a changer le stack.f de interf * renvoit .true. si l'argument en spos est une matrice * sinon appelle error et renvoit .false. * Entree : * fname : nom de la routine appellante pour le message * d'erreur * spos : position ds la pile * Sortie * [it,m,n] caracteristiques de la matrice * lr : pointe sur la partie reelle ( si la matrice est a * a(1,1)=stk(lr) * si l'on veut acceder a des entiers * a(1,1)=istk(adr(lr,0)) * lc : pointe sur la partie imaginaire si elle existe sinon sur zero *------------------------------------------------------------------ */ int C2F(getvectcol)(fname, topk, spos, it, m, n, lr, lc, fname_len) char *fname; integer *topk, *spos, *it, *m, *n, *lr, *lc; unsigned long fname_len; { if ( C2F(getmati)(fname, topk, spos, Lstk(*spos ), it, m, n, lr, lc, &c_false, &cx0, fname_len) == FALSE_ ) return FALSE_; if (*n != 1) { Scierror(999,"%s: argument %d should be a column vector \r\n", get_fname(fname,fname_len),Rhs + (*spos - *topk)); return FALSE_; } return TRUE_; } int C2F(getlistsimat)(fname, topk, spos, lnum, m, n, ix, j, lr, nlr, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n, *ix, *j, *lr, *nlr; unsigned long fname_len; { integer nv; integer ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getsmati)(fname, topk, spos, &ili, m, n, ix, j, lr, nlr, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * recuperation d'un pointer *------------------------------------------------------------------- */ int C2F(getpointer)(fname, topk, lw, lr, fname_len) char *fname; integer *topk, *lw, *lr; unsigned long fname_len; { return C2F(getpointeri)(fname, topk, lw,Lstk(*lw), lr, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------ * getlistpointer : * checks that spos object is a list * checks that lnum-element of the list exists and is a pointer * extracts pointer value * In : * fname : name of calling function for error message * topk : stack ref for error message * spos : stack position * Out : * lw : stk(lw) a <> casted to a double *------------------------------------------------------------------ */ int C2F(getlistpointer)(fname, topk, spos, lnum, lw, fname_len) char *fname; integer *topk, *spos, *lnum, *lw; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(getpointeri)(fname, topk, spos, &ili, lw, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(getpointeri)(fname, topk, spos, lw, lr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *lr; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 128) { sciprint("----%d\r\n",*istk(il)); if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a boxed pointer\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(201,"%s: argument %d should be a boxed pointer\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *lr = sadr(il+4); return TRUE_; } /*----------------------------------------------------------- * creates a matlab-like sparse matrix *-----------------------------------------------------------*/ int C2F(mspcreate)(lw, m, n, nzMax, it) integer *lw, *m, *n, *nzMax, *it; { integer ix1; integer jc, il, ir; int NZMAX; int k,pr; double size; if (*lw + 1 >= Bot) { Scierror(18,"too many names\r\n"); return FALSE_; } il = iadr(*Lstk(*lw )); NZMAX=*nzMax; if (NZMAX==0) NZMAX=1; ix1 = il + 4 + (*n + 1) + NZMAX; size = (*it + 1) * NZMAX ; Err = sadr(ix1) - *Lstk(Bot ); if (Err > -size ) { Scierror(17,"stack size exceeded (Use stacksize function to increase it)\r\n"); return FALSE_; }; *istk(il ) = 7; /* si m*n=0 les deux dimensions sont mises a zero. *istk(il +1) = Min(*m , *m * *n); *istk(il + 1 +1) = Min(*n, *m * *n); */ *istk(il +1) = *m; *istk(il + 2) = *n; *istk(il + 3) = *it; *istk(il + 4) = NZMAX; jc = il + 5; for (k=0; k<*n+1; ++k) *istk(jc+k)=0; /* Jc =0 */ ir = jc + *n + 1; for (k=0; kld||ld+ix1>l) C2F(unsfdcopy)(&ix1, stk(l), &cx1, stk(ld), &cx1); else C2F(dcopy)(&ix1, stk(l), &cx1, stk(ld), &cx1); *Lstk(*lwd +1) = ld + ix1; return 0; } /*------------------------------------------------ * copie l'objet qui est a la position lw de la pile * a la position lwd de la pile * copie faite avec dcopy * et verification *------------------------------------------------*/ int C2F(vcopyobj)(fname, lw, lwd, fname_len) char *fname; integer *lw, *lwd; unsigned long fname_len; { integer l; integer l1, lv; l = *Lstk(*lw ); lv = *Lstk(*lw +1) - *Lstk(*lw ); l1 = *Lstk(*lwd ); if (*lwd + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } Err = *Lstk(*lwd ) + lv - *Lstk(Bot ); if (Err > 0) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n", get_fname(fname,fname_len)); return FALSE_; } /* check for overlaping region */ if (l+lv>l1||l1+lv>l) C2F(unsfdcopy)(&lv, stk(l), &cx1, stk(l1), &cx1); else C2F(dcopy)(&lv, stk(l), &cx1, stk(l1), &cx1); *Lstk(*lwd +1) = *Lstk(*lwd ) + lv; return TRUE_; } /*------------------------------------------------== * suppose qu'il y a une matrice en lw de taille it1,m1,n1,mn1, * et une autre en lw+1 de taille it2,m2,n2,mn2 * et echange les matrices et change les valeurs de it1,m1,n1,... * apres echange la taille de la matrice en lw est stocke ds(it1,m1,n1) * et celle en lw+1 est stocke ds (it2,m2,n2) * effet de bord il faut que lw+2 soit une place libre *------------------------------------------------== */ int C2F(swapmat)(fname, topk, lw, it1, m1, n1, mn1, it2, m2, n2, mn2, fname_len) char *fname; integer *topk, *lw, *it1, *m1, *n1, *mn1, *it2, *m2, *n2, *mn2; unsigned long fname_len; { integer ix1, ix2; integer lc, lr; ix1 = *lw + 1; if ( C2F(cremat)(fname, &ix1, it1, m1, n1, &lr, &lc, fname_len)== FALSE_) return FALSE_ ; ix1 = *lw + 2; C2F(copyobj)(fname, lw, &ix1, fname_len); ix1 = *lw + 1; C2F(copyobj)(fname, &ix1, lw, fname_len); ix1 = *lw + 2; ix2 = *lw + 1; C2F(copyobj)(fname, &ix1, &ix2, fname_len); if ( C2F(getmat)(fname, topk, lw, it1, m1, n1, &lr, &lc, fname_len) == FALSE_ ) return FALSE_; ix1 = *lw + 1; if (C2F(getmat)(fname, topk, &ix1, it2, m2, n2, &lr, &lc, fname_len) == FALSE_ ) return FALSE_; *mn1 = *m1 * *n1; *mn2 = *m2 * *n2; return TRUE_; } /*------------------------------------------------== * verifie qu'en lw il y a une matrice de taille (it1,m1,n1) * deplace cette matrice en lw+1, en reservant en lw * la place pour stocker une matrice (it,m,n) * insmat verifie qu'on a la place de faire tout ca * appelle error en cas de probleme * Remarque : noter par exemple que si it=it1,m1=m,n1=n * alors apres le contenu de la matrice en lw est une copie de * celle en lw+1 * Remarque : lw doit etre top car sinon on perd ce qu'il y avait avant * en lw+1,....,lw+n * Entree : * lw : position * it ,m,n : taille de la matrice a inserer * Sortie : * lr : pointe sur la partie reelle de la matrice * en lw ( a(1,1)=stk(lr)) * lc : pointe sur la partie imaginaire si besoin est * lr1,lc1 : meme signification mais pour la matrice en lw+1 * ( matrice qui a ete copiee de lw a lw+1 *------------------------------------------------== */ int C2F(insmat)(topk, lw, it, m, n, lr, lc, lr1, lc1) integer *topk, *lw, *it, *m, *n, *lr, *lc, *lr1, *lc1; { integer ix1; integer c_n1 = -1; integer m1, n1; integer lc0, it1, lr0; if (C2F(getmat)("insmat", topk, lw, &it1, &m1, &n1, &lr0, &lc0, 6L) == FALSE_) return FALSE_; if (C2F(cremat)("insmat", lw, it, m, n, lr, lc, 6L) == FALSE_) return FALSE_; ix1 = *lw + 1; if (C2F(cremat)("insmat", &ix1, &it1, &m1, &n1, lr1, lc1, 6L) == FALSE_) return FALSE_; ix1 = m1 * n1 * (it1 + 1); C2F(dcopy)(&ix1, stk(lr0 ), &c_n1, stk(*lr1 ), &c_n1); return TRUE_; } /*------------------------------------------------ * imprime le contenu de la pile en lw en mode entier ou * double precision suivant typ *------------------------------------------------*/ int C2F(stackinfo)(lw, typ) integer *lw, *typ; { integer ix, l, m, n; integer il, nn; if (*lw == 0) { return 0; } il = iadr(*Lstk(*lw )); if (*istk(il ) < 0) { il = iadr(*istk(il +1)); } m = *istk(il +1); n = *istk(il + 1 +1); sciprint("-----------------stack-info-----------------\r\n"); sciprint("lw=%d -[istk]-> il lw+1 -[istk]-> %d \r\n", *lw,iadr(*Lstk(*lw+1))); sciprint("istk(%d:..) ->[%d %d %d %d ....]\r\n", il, istk(il),istk(il+1),istk(il+2),istk(il+3) ); if (*typ == 1) { l = sadr(il+4); nn = Min(m*n,3); for (ix = 0; ix <= nn-1 ; ++ix) { sciprint("%5.2f ",stk(l + ix )); } } else { l = il + 4; nn = Min(m*n,3); for (ix = 0; ix <= nn-1; ++ix) { sciprint("%5d ",istk(l + ix )); } } sciprint("\r\n-----------------stack-info-----------------\r\n"); return 0; } /*------------------------------------------------ * allmat : * checks if object at position lw is a matrix * (scalar,string,polynom) * In : * fname,topk,lw * Out : * m,n *------------------------------------------------*/ int C2F(allmat)(fname, topk, lw, m, n, fname_len) char *fname; integer *topk, *lw, *m, *n; unsigned long fname_len; { integer itype, il; il = iadr(*Lstk(*lw )); if (*istk(il ) < 0) il = iadr(*istk(il +1)); itype = *istk(il ); if (itype != 1 && itype != 2 && itype != 10) { Scierror(209,"%s: Argument %d wrong type argument, expecting a matrix\r\n", get_fname(fname,fname_len) , Rhs + (*lw - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); return TRUE_; } /*------------------------------------------------ * Assume that object at position lw is a matrix * and set its size to (m,n) *------------------------------------------------*/ int C2F(allmatset)(fname, lw, m, n, fname_len) char *fname; integer *lw, *m, *n; unsigned long fname_len; { integer il; il = iadr(*Lstk(*lw )); if (*istk(il ) < 0) il = iadr(*istk(il +1)); *istk(il + 1) = *m; *istk(il + 2) = *n; return 0; } /*------------------------------------------------ * cree un objet vide en lw et met a jour lw+1 * en fait lw doit etre top * verifie les cas particuliers lw=0 ou lw=1 * ainsi que le cas particulier ou une fonction * n'a pas d'arguments (ou il faut faire top=top+1) *------------------------------------------------ */ int C2F(objvide)(fname, lw, fname_len) char *fname; integer *lw; unsigned long fname_len; { if (*lw == 0 || Rhs < 0) { ++(*lw); } *istk(iadr(*Lstk(*lw )) ) = 0; *Lstk(*lw +1) = *Lstk(*lw ) + 2; return 0; } /*------------------------------------------------ * renvoit .true. si l'argument en lw est un ``external'' * sinon appelle error et renvoit .false. * si l'argument est un external de type string * on met a jour la table des fonctions externes * corespondante en appellant fun * Entree : * fname : nom de la routine appellante pour le message * d'erreur * topk : numero d'argument d'appel pour le message d'ereur * lw : position ds la pile * Sortie * type vaut true ou false * si l'external est de type chaine de caracteres * la chaine est mise ds name * et type est mise a true *------------------------------------------------ */ int C2F(getexternal)(fname, topk, lw, namex, typex, setfun, fname_len, name_len) char *fname; integer *topk, *lw; char *namex; int *typex; void (*setfun) __PARAMS((char *,int *)); unsigned long fname_len; unsigned long name_len; { int ret_value; integer irep; integer m, n; integer il, lr; integer nlr; int i; il = C2F(gettype)(lw); switch ( il) { case 11 : case 13 : case 15 : ret_value = TRUE_; *typex = FALSE_; break; case 10 : ret_value = C2F(getsmat)(fname, topk, lw, &m, &n, &cx1, &cx1, &lr, &nlr, fname_len); *typex = TRUE_; for (i=0; i < (int)name_len ; i++ ) namex[i] = ' '; if (ret_value == TRUE_) { C2F(cvstr)(&nlr, istk(lr ), namex, &cx1, name_len); namex[nlr] = '\0'; (*setfun)(namex, &irep); /* , name_len); */ if (irep == 1) { Scierror(50,"%s: entry point %s not found in predefined tables or link table\r\n",get_fname(fname,fname_len),namex); ret_value = FALSE_; } } break; default: Scierror(211,"%s: Argument %d: wrong type argument, expecting a function\r\n\tor string (external function)\r\n", get_fname(fname,fname_len), Rhs + (*lw - *topk)); ret_value = FALSE_; break; } return ret_value; } /*------------------------------------------------ *------------------------------------------------ */ int C2F(checkval)(fname, ival1, ival2, fname_len) char *fname; integer *ival1, *ival2; unsigned long fname_len; { if (*ival1 != *ival2) { Scierror(999,"%s: incompatible sizes \r\n",get_fname(fname,fname_len)); return FALSE_; } ; return TRUE_; } /*------------------------------------------------------------- * recupere si elle existe la variable name dans le stack et * met sa valeur a la position top et top est incremente * ansi que rhs * si la variable cherchee n'existe pas on renvoit false *------------------------------------------------------------- */ int C2F(optvarget)(fname, topk, iel, namex, fname_len, name_len) char *fname; integer *topk, *iel; char *namex; unsigned long fname_len; unsigned long name_len; { integer id[nsiz]; C2F(cvname)(id, namex, &cx0, name_len); Fin = 0; /* recupere la variable et incremente top */ C2F(stackg)(id); if (Fin == 0) { Scierror(999,"%s: optional argument %d not given and default value %s not found\r\n", get_fname(fname,fname_len),*iel,namex); return FALSE_; } ++Rhs; return TRUE_; } /*------------------------------------------------------------- * this routine adds nlr characters (coded in istk(*lr)) * + a null character in Scilab character buffer C2F(cha1).buf * the characters are stored at position lbuf * lbuf,lbufi,lbuff are the updated : * buf(lbufi:lbuff) will give the characters in buf at Fortran level * and lbuf will give the next available position (i.e lbuff+2 since * '\0' is added at position lbuff+1 * * Note that at Fortran level buf(lbufi:lbuff) can be used as a C string argument * since it is null terminated * *------------------------------------------------------------- */ int C2F(bufstore)(fname, lbuf, lbufi, lbuff, lr, nlr, fname_len) char *fname; integer *lbuf, *lbufi, *lbuff, *lr, *nlr; unsigned long fname_len; { *lbufi = *lbuf; *lbuff = *lbufi + *nlr - 1; *lbuf = *lbuff + 2; if (*lbuff > bsiz) { Scierror(999,"%f: No more space to store string arguments\r\n", get_fname(fname,fname_len) ); return FALSE_; } /* lbufi is a Fortran indice ==> offset -1 at C level */ C2F(cvstr)(nlr, istk(*lr ), C2F(cha1).buf + (*lbufi - 1), &cx1, *lbuff - (*lbufi - 1)); C2F(cha1).buf[*lbuff] = '\0'; return TRUE_; } /*------------------------------------------------------------- * *------------------------------------------------------------- */ int C2F(credata)(fname, lw, m, fname_len) char *fname; integer *lw, m; unsigned long fname_len; { integer lr; lr = *Lstk(*lw ); if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } Err = lr - *Lstk(Bot); if (Err > -m ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; /* *Lstk(*lw +1) = lr + 1 + m/sizeof(double); */ /* type 0 */ *istk(iadr(lr)) = 0; *Lstk(*lw +1) = lr + (m+sizeof(double)-1)/sizeof(double); return TRUE_; } /* ============================================================== MATRIX OF HANDLE ================================================================= */ /*--------------------------------------------------------- * internal function used by crehmat and listcrehmat *---------------------------------------------------------- */ int C2F(crehmati)(fname, stlw, m, n, lr, flagx, fname_len) char *fname; integer *stlw, *m, *n, *lr; int *flagx; unsigned long fname_len; { integer ix1; integer il; double size = ((double) *m) * ((double) *n); il = iadr(*stlw); ix1 = il + 4; Err = sadr(ix1) - *Lstk(Bot ); if ( (double) Err > -size ) { Scierror(17,"%s: stack size exceeded (Use stacksize function to increase it)\r\n",get_fname(fname,fname_len)); return FALSE_; }; if (*flagx) { *istk(il ) = 9; /* if m*n=0 then both dimensions are to be set to zero */ *istk(il + 1) = Min(*m , *m * *n); *istk(il + 2) = Min(*n ,*m * *n); *istk(il + 3) = 0; } ix1 = il + 4; *lr = sadr(ix1); return TRUE_; } /*---------------------------------------------------------- * listcrehmat(top,numero,lw,....) * le numero ieme element de la liste en top doit etre un matrice * stockee a partir de Lstk(lw) * doit mettre a jour les pointeurs de la liste * ainsi que stk(top+1) * si l'element a creer est le dernier * lw est aussi mis a jour *---------------------------------------------------------- */ int C2F(listcrehmat)(fname, lw, numi, stlw, m, n, lrs,fname_len) char *fname; integer *lw, *numi, *stlw, *m, *n, *lrs; unsigned long fname_len; { integer ix1,il ; if (C2F(crehmati)(fname, stlw, m, n, lrs, &c_true, fname_len)==FALSE_) return FALSE_ ; *stlw = *lrs + *m * *n; il = iadr(*Lstk(*lw )); ix1 = il + *istk(il +1) + 3; *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1; if (*numi == *istk(il +1)) *Lstk(*lw +1) = *stlw; return TRUE_; } /*---------------------------------------------------------- * crehmat : * checks that a matrix of handle of size [m,n] can be stored at position lw * <> to data is returned on success * In : * lw : position (entier) * m, n dimensions * Out : * lr : stk(lr+i-1)= h(i) * Side effect : if matrix creation is possible * [m,n] are stored in Scilab stack * and lr is returned but stk(lr+..) are unchanged *---------------------------------------------------------- */ int C2F(crehmat)(fname, lw, m, n, lr, fname_len) char *fname; integer *lw, *m, *n, *lr; unsigned long fname_len; { if (*lw + 1 >= Bot) { Scierror(18,"%s: too many names\r\n",get_fname(fname,fname_len)); return FALSE_; } if ( C2F(crehmati)(fname, Lstk(*lw ), m, n, lr, &c_true, fname_len) == FALSE_) return FALSE_ ; *Lstk(*lw +1) = *lr + *m * *n; return TRUE_; } /*------------------------------------------------------------------ * getlisthmat : * checks that spos object is a list * checks that lnum-element of the list exists and is a matrix * extracts matrix information(m,n,lr) * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position * Out : * [m,n] matrix dimensions * lr : stk(lr+i-1)= h(i)) *------------------------------------------------------------------ */ int C2F(getlisthmat)(fname, topk, spos, lnum, m, n, lr, fname_len) char *fname; integer *topk, *spos, *lnum, *m, *n, *lr; unsigned long fname_len; { integer nv, ili; if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE_) return FALSE_; if (*lnum > nv) { Scierror(999,"%s: argument %d should be a list of size at least %d \r\n", get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum); return FALSE_; } return C2F(gethmati)(fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len); } /*------------------------------------------------------------------- * gethmat : * check that object at position lw is a matrix * In : * fname : name of calling function for error message * topk : stack ref for error message * lw : stack position ( ``in the top sense'' ) * Out : * [m,n] matrix dimensions * lr : stk(lr+i-1)= h(i) *------------------------------------------------------------------- */ int C2F(gethmat)(fname, topk, lw, m, n, lr, fname_len) char *fname; integer *topk, *lw, *m, *n, *lr; unsigned long fname_len; { return C2F(gethmati)(fname, topk, lw,Lstk(*lw), m, n, lr, &c_false, &cx0, fname_len); } /*------------------------------------------------------------------- * For internal use *------------------------------------------------------------------- */ int C2F(gethmati)(fname, topk, spos, lw, m, n, lr, inlistx, nel, fname_len) char *fname; integer *topk, *spos, *lw, *m, *n, *lr; int *inlistx; integer *nel; unsigned long fname_len; { integer il; il = iadr(*lw); if (*istk(il ) < 0) il = iadr(*istk(il +1)); if (*istk(il ) != 9) { if (*inlistx) Scierror(999,"%s: argument %d >(%d) should be a matrix of handle\r\n", get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel); else Scierror(201,"%s: argument %d should be a matrix of handle\r\n",get_fname(fname,fname_len), Rhs + (*spos - *topk)); return FALSE_; } *m = *istk(il + 1); *n = *istk(il + 2); *lr = sadr(il+4); return TRUE_; } /********************************************************************** * Scilab Error at C level **********************************************************************/ extern int C2F(error) __PARAMS((integer *n)); extern int C2F(errmgr) __PARAMS((integer *n, integer *errtyp)); extern int C2F(errmsg) __PARAMS((integer *n, integer *errtyp)); extern int C2F(errmds) __PARAMS((integer *num, integer *imess, integer *imode)); extern int C2F(depfun) __PARAMS((integer *lunit, int *trace, int *first)); extern int C2F(depexec) __PARAMS((integer *lunit, int *trace, int *first, int *pflag)); extern int C2F(errloc) __PARAMS((integer *n)); static int Scierror_internal __PARAMS((integer *n,char *buffer)); #if WIN32 #define vsnprintf _vsnprintf #endif /* * as sciprint but with an added first argument * which is ignored (used in do_printf) */ #ifdef __STDC__ int Scierror(int iv,char *fmt,...) #else /*VARARGS0*/ int Scierror(va_alist) va_dcl #endif { int retval; integer lstr; va_list ap; char s_buf[bsiz]; #ifdef __STDC__ va_start(ap,fmt); #else int iv; char *fmt; va_start(ap); iv = va_arg(ap,int); fmt = va_arg(ap, char *); #endif #if defined (vsnprintf) || defined (linux) retval= vsnprintf(s_buf,bsiz-1, fmt, ap ); #else retval= vsprintf(s_buf,fmt, ap ); #endif if (retval == -1) { s_buf[bsiz-1]='\0'; } lstr=strlen(s_buf); va_end(ap); Scierror_internal(&iv,s_buf); return retval; } static int Scierror_internal(n,buffer) integer *n; char *buffer; { integer imode; int trace; integer imess; integer errtyp, num, lct1, len; C2F(errmds)(&num, &imess, &imode); trace = ! ((num < 0 || num == *n) && imess != 0); /* de-activate output control */ lct1 = C2F(iop).lct[0]; C2F(iop).lct[0] = 0; errtyp = 0; if (C2F(errgst).err1 == 0 && C2F(errgst).err2 == 0) { /* . locate the error in the current statement */ if (trace) C2F(errloc)(n); /* . output error message */ else C2F(iop).lct[0] = -1; /* XXX C2F(errmsg)(n, &errtyp); */ errtyp=0; C2F(freemsgtable)(); C2F(errstore)(n); len=strlen(buffer); C2F(msgstore)(buffer,&len); if (C2F(iop).lct[0] != -1) sciprint(buffer); C2F(iop).lct[0] = 0; } /* handle the error */ C2F(errmgr)(n, &errtyp); /* re-activate output control */ C2F(iop).lct[0] = lct1; return 0; }