get rid of integer type (=> int) ... really useles except for Fortran fan (but just...
[scilab.git] / scilab / modules / core / src / c / stack1.c
1 /*
2  * Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
3  * Copyright (C) 1998-2002 - ENPC - Jean-Philippe Chancelier
4  * Copyright (C) 1998-2007 - INRIA - Serge STEER
5  * Copyright (C) 2004-2007 - INRIA - Allan CORNET
6  * Copyright (C) 2006-2008 - INRIA - Sylvestre LEDRU
7  * 
8  * This file must be used under the terms of the CeCILL.
9  * This source file is licensed as described in the file COPYING, which
10  * you should have received as part of this distribution.  The terms
11  * are also available at    
12  * http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
13  *
14  * Please note that piece of code will be rewrited for the Scilab 6 family
15  */
16 /*    Scilab Memory Management library (Stack API) */
17 #include <string.h>
18 #include "stack-c.h"
19 #include "stack1.h"
20 #include "stack2.h"
21 #include "sciprint.h"
22 #include "cvstr.h"
23 #include "localization.h"
24 #include "Scierror.h"
25
26 /* Table of constant values */
27
28 static int cx0 = 0;
29 static int cx1 = 1;
30 static int cx4 = 4;
31 static int c_true = TRUE;
32 static int c_false = FALSE;
33
34 /* Static function declarations ... Function only used here */
35 static int C2F(getwsmati)(char * fname, int *topk, int * spos,int * lw,int * m, int *n,int * ilr,int * ilrd ,int * inlistx,int* nel,unsigned long fname_len);
36 static int C2F(gethmati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *lr,int *inlistx,int *nel,unsigned long fname_len);
37 static int C2F(getsmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *i__, int *j, int *lr, int *nlr, int *inlist__, int *nel, unsigned long fname_len);
38 static int C2F(getpointeri) (char *fname, int *topk, int *spos, int *lw, int *lr, int *inlist__, int *nel, unsigned long fname_len);
39 static int C2F(getimati)(char *fname, int *topk, int *spos, int *lw, int *it, int *m, int *n, int *lr, int *inlistx, int *nel, long unsigned int fname_len);
40 static int C2F(getbmati) (char *fname, int *topk, int *spos, int *lw, int *m, int *n, int *lr, int *inlist__, int *nel, unsigned long fname_len);
41 static int C2F(cremati)(char *fname,int *stlw,int *it,int *m,int *n,int *lr,int *lc,int *flagx,unsigned long fname_len);
42 static int C2F(getmati)(char *fname,int *topk,int *spos,int *lw,int *it,int *m,int *n,int *lr,int *lc,int *inlistx,int *nel,unsigned long fname_len);
43 static int C2F(crebmati)(char *fname,int *stlw,int *m,int *n,int *lr,int *flagx,unsigned long fname_len);
44 static int C2F(crehmati)(char *fname,int *stlw,int *m,int *n,int *lr,int *flagx,unsigned long fname_len);
45 static int C2F(crepointeri)(char *fname,int *stlw,int *lr,int *flagx,unsigned long fname_len);
46 static int C2F(cresparsei)(char *fname,int *stlw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,unsigned long fname_len); 
47 static int C2F(getsparsei)(char *fname,int *topk,int *spos,int *lw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,int *inlistx,int *nellist,unsigned long fname_len);
48
49
50 int C2F(getrsparse)(char *fname, int *topk, int *lw, int *m, int *n,  int *nel, int *mnel, int *icol, int *lr,unsigned long fname_len);
51 int C2F(getlistsmat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *ix,int *j,int *lr,int *nlr,unsigned long fname_len);
52 int cre_smat_from_str_i(char *fname, int *lw, int *m, int *n, char *Str[],unsigned long fname_len, int *rep);
53 int cre_sparse_from_ptr_i(char *fname, int *lw, int *m, int *n, SciSparse *S, unsigned long fname_len,  int *rep);
54 int crelist_G(int *slw,int *ilen,int *lw,int type);
55
56 /**********************************************************************
57  * MATRICES 
58  **********************************************************************/
59
60 /*------------------------------------------------------------------ 
61  * getlistmat : 
62  *    checks that spos object is a list 
63  *    checks that lnum-element of the list exists and is a matrix 
64  *    extracts matrix information(it,m,n,lr,lc) 
65  *     In  : 
66  *       fname : name of calling function for error message 
67  *       topk  : stack ref for error message 
68  *       lw    : stack position 
69  *     Out : 
70  *       [it,m,n] matrix dimensions 
71  *       lr : stk(lr+i-1)= real(a(i)) 
72  *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 
73  *------------------------------------------------------------------ */
74
75 int C2F(getlistmat)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
76 {
77   int nv, ili;
78
79   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE )
80     return FALSE;
81
82   if (*lnum > nv) {
83     Scierror(999,_("%s: argument %d should be a list of size at least %d.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
84     return FALSE;
85   }
86   return C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len);
87
88
89 /*------------------------------------------------------------------- 
90  * getmat :
91  *     check that object at position lw is a matrix 
92  *     In  : 
93  *       fname : name of calling function for error message 
94  *       topk  : stack ref for error message 
95  *       lw    : stack position ( ``in the top sense'' )
96  *     Out : 
97  *       [it,m,n] matrix dimensions 
98  *       lr : stk(lr+i-1)= real(a(i)) 
99  *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 
100  *------------------------------------------------------------------- */
101
102 int C2F(getmat)(char *fname,int *topk,int *lw,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
103 {
104   return C2F(getmati)(fname, topk, lw,Lstk(*lw), it, m, n, lr, lc, &c_false, &cx0, fname_len);
105 }
106
107 /*------------------------------------------------------------------
108  * getrmat like getmat but we check for a real matrix 
109  *------------------------------------------------------------------ */
110
111 int C2F(getrmat)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
112 {
113   int lc, it;
114
115   if ( C2F(getmat)(fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE )
116     return FALSE;
117
118   if (it != 0) {
119     Scierror(202,_("%s: Wrong type for argument %d: Real matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
120     return FALSE;
121   }
122   return TRUE;
123 }
124 /* ------------------------------------------------------------------
125  * getcmat like getmat but we check for a complex matrix
126  *------------------------------------------------------------------ */
127
128 int C2F(getcmat)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
129 {
130   int lc, it;
131
132   if ( C2F(getmat)(fname, topk, lw, &it, m, n, lr, &lc, fname_len) == FALSE )
133     return FALSE;
134
135   if (it != 1) {
136     Scierror(202,_("%s: Wrong type for argument %d: Real matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
137     return FALSE;
138   }
139   return TRUE;
140 }
141
142 /*------------------------------------------------------------------ 
143  * matsize :
144  *    like getmat but here m,n are given on entry 
145  *    and we check that matrix is of size (m,n) 
146  *------------------------------------------------------------------ */
147
148 int C2F(matsize)(char *fname,int *topk,int *lw,int *m,int *n,unsigned long fname_len)
149 {
150   int m1, n1, lc, it, lr;
151   
152   if (  C2F(getmat)(fname, topk, lw, &it, &m1, &n1, &lr, &lc, fname_len)  == FALSE)
153     return FALSE;
154   if (*m != m1 || *n != n1) {
155     Scierror(205,_("%s: Wrong size for argument %d: (%d,%d) expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk), *m,*n);
156     return FALSE;
157   }
158   return  TRUE;
159 }
160
161 /*------------------------------------------------------------------- 
162  * For internal use 
163  *------------------------------------------------------------------- */
164
165 static int C2F(getmati)(char *fname,int *topk,int *spos,int *lw,int *it,int *m,int *n,int *lr,int *lc,int *inlistx,int *nel,unsigned long fname_len)
166 {
167   int il;
168   il = iadr(*lw);
169   if (*istk(il ) < 0) il = iadr(*istk(il +1));
170   if (*istk(il ) != 1) {
171           if (*inlistx) {
172                   Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Real or complex matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
173           } else {
174                   Scierror(201,_("%s: Wrong type for argument %d: Real or complex matrix expected.\n"),get_fname(fname,fname_len),
175                Rhs + (*spos - *topk));
176           }
177     return  FALSE;
178   }
179   *m = *istk(il + 1);
180   *n = *istk(il + 2);
181   *it = *istk(il + 3);
182   *lr = sadr(il+4);
183   if (*it == 1)  *lc = *lr + *m * *n;
184   return TRUE;
185
186
187
188 /*---------------------------------------------------------- 
189  *  listcremat(top,numero,lw,....) 
190  *      le numero ieme element de la liste en top doit etre un matrice 
191  *      stockee a partir de Lstk(lw) 
192  *      doit mettre a jour les pointeurs de la liste 
193  *      ainsi que stk(top+1) 
194  *      si l'element a creer est le dernier 
195  *      lw est aussi mis a jour 
196  *---------------------------------------------------------- */
197
198 int C2F(listcremat)(char *fname,int *lw,int *numi,int *stlw,int *it,int *m,int *n,int *lrs,int *lcs,unsigned long fname_len)
199 {
200   int ix1,il ;
201     
202   if (C2F(cremati)(fname, stlw, it, m, n, lrs, lcs, &c_true, fname_len)==FALSE)
203     return FALSE ;
204
205   *stlw = *lrs + *m * *n * (*it + 1);
206   il = iadr(*Lstk(*lw ));
207   ix1 = il + *istk(il +1) + 3;
208   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
209   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
210   return TRUE;
211
212
213 /*---------------------------------------------------------- 
214  *  cremat :
215  *   checks that a matrix [it,m,n] can be stored at position  lw 
216  *   <<pointers>> to real and imaginary part are returned on success
217  *   In : 
218  *     lw : position (entier) 
219  *     it : type 0 ou 1 
220  *     m, n dimensions 
221  *   Out : 
222  *     lr : stk(lr+i-1)= real(a(i)) 
223  *     lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 
224  *   Side effect : if matrix creation is possible 
225  *     [it,m,n] are stored in Scilab stack 
226  *     and lr and lc are returned 
227  *     but stk(lr+..) and stk(lc+..) are unchanged 
228  *---------------------------------------------------------- */
229
230 int C2F(cremat)(char *fname,int *lw,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
231 {
232
233   if (*lw + 1 >= Bot) {
234           Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
235     return FALSE;
236   }
237   if ( C2F(cremati)(fname, Lstk(*lw ), it, m, n, lr, lc, &c_true, fname_len) == FALSE)
238     return FALSE ;
239   *Lstk(*lw +1) = *lr + *m * *n * (*it + 1);
240   return TRUE;
241
242
243 /*-------------------------------------------------
244  * Similar to cremat but we only check for space 
245  * no data is stored 
246  *-------------------------------------------------*/
247
248 int C2F(fakecremat)(int *lw,int *it,int *m,int *n,int *lr,int *lc)
249 {
250   if (*lw + 1 >= Bot) return FALSE;
251   if (C2F(cremati)("cremat", Lstk(*lw ), it, m, n, lr, lc, &c_false, 6L) == FALSE) 
252     return FALSE;
253   *Lstk(*lw +1) = *lr + *m * *n * (*it + 1);
254   return TRUE;
255
256
257
258 /*--------------------------------------------------------- 
259  * internal function used by cremat and listcremat 
260  *---------------------------------------------------------- */
261 static int C2F(cremati)(char *fname,int *stlw,int *it,int *m,int *n,int *lr,int *lc,int *flagx,unsigned long fname_len)
262 {
263   int ix1;
264   int il;
265   double size = ((double) *m) * ((double) *n) * ((double) (*it + 1));
266   il = iadr(*stlw);
267   ix1 = il + 4;
268   Err = sadr(ix1) - *Lstk(Bot );
269   if ( (double) Err > -size ) {
270           Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
271     return FALSE;
272   };
273   if (*flagx) {
274     *istk(il ) = 1;
275     /* if m*n=0 then both dimensions are to be set to zero */
276     *istk(il + 1) = Min(*m , *m * *n);
277     *istk(il + 2) = Min(*n ,*m * *n);
278     *istk(il + 3) = *it;
279   }
280   ix1 = il + 4;
281   *lr = sadr(ix1);
282   *lc = *lr + *m * *n;
283   return TRUE;
284
285
286 /*--------------------------------------------------------- 
287 *     same as cremat, but without test ( we are below bot)
288 *     and adding a call to putid 
289 *     cree une variable de type matrice 
290 *     de nom id 
291 *     en lw : sans verification de place 
292 *---------------------------------------------------------- */
293 int C2F(crematvar)(int *id, int *lw, int *it, int *m, int *n, double *rtab, double *itab)
294 {
295
296         /* Local variables */
297         int i__1;
298         static int lc, il, lr;
299         static int c__1 = 1;
300
301         /* Parameter adjustments */
302         --itab;
303         --rtab;
304         --id;
305
306         /* Function Body */
307         C2F(putid)(&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
308         il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
309         *istk(il) = 1;
310         *istk(il+1) = *m;
311         *istk(il+2) = *n;
312         *istk(il+3) = *it;
313         i__1 = il + 4;
314         lr = i__1 / 2 + 1;
315         lc = lr + *m * *n;
316         if (*lw < C2F(vstk).isiz) 
317         {
318                 i__1 = il + 4;
319                 C2F(vstk).lstk[*lw] = i__1 / 2 + 1 + *m * *n * (*it + 1);
320         }
321         i__1 = *m * *n;
322         C2F(unsfdcopy)(&i__1, &rtab[1], &c__1, stk(lr), &c__1);
323         if (*it == 1) 
324         {
325                 i__1 = *m * *n;
326                 C2F(unsfdcopy)(&i__1, &itab[1], &c__1, stk(lc), &c__1);
327         }
328         return 0;
329
330
331
332 /*--------------------------------------------------------- 
333 *     crebmat without check and call to putid 
334 *---------------------------------------------------------- */
335 int C2F(crebmatvar)(int *id, int *lw, int *m, int *n, int *val)
336 {
337         /* Local variables */
338         static int il, lr;
339         int i__1;
340         static int c__1 = 1;
341
342         /* Parameter adjustments */
343         --val;
344         --id;
345
346         C2F(putid)(&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
347         il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
348         *istk(il) = 4;
349         *istk(il+1) = *m;
350         *istk(il+2) = *n;
351         lr = il + 3;
352         i__1 = il + 3 + *m * *n + 2;
353         C2F(vstk).lstk[*lw] = i__1 / 2 + 1;
354         i__1 = *m * *n;
355         C2F(icopy)(&i__1, &val[1], &c__1, istk(lr), &c__1);
356         return 0;
357
358 /*--------------------------------------------------------- 
359 *     cresmatvar without check and call to putid 
360 *---------------------------------------------------------- */
361 int C2F(cresmatvar)(int *id, int *lw, char *str, int *lstr, unsigned long str_len)
362 {
363         static int il, mn, lr1, ix1, ilp;
364         static int ilast;
365         static int c__0 = 0;
366
367         /* Parameter adjustments */
368         --id;
369
370         C2F(putid)(&C2F(vstk).idstk[*lw * 6 - 6], &id[1]);
371         il = C2F(vstk).lstk[*lw - 1] + C2F(vstk).lstk[*lw - 1] - 1;
372         mn = 1;
373         ix1 = il + 4 + (*lstr + 1) + (mn + 1);
374         *istk(il) = 10;
375         *istk(il+1) = 1;
376         *istk(il+2) = 1;
377         *istk(il+3) = 0;
378         ilp = il + 4;
379         *istk(ilp) = 1;
380         *istk(ilp+1) = *istk(ilp) + *lstr;
381         ilast = ilp + mn;
382         lr1 = ilast + *istk(ilp);
383         C2F(cvstr)(lstr, istk(lr1), str, &c__0, str_len);
384         ix1 = ilast + *istk(ilast);
385         C2F(vstk).lstk[*lw] = ix1 / 2 + 1;
386         return 0;
387 }
388
389 /**********************************************************************
390  * INT MATRICES 
391  **********************************************************************/
392
393 /* compute requested memory in number of ints */
394
395 #define memused(it,mn) ((((mn)*( it % 10))/sizeof(int))+1)
396
397
398 /*------------------------------------------------------------------ 
399  * getilistmat : 
400  *    checks that spos object is a list 
401  *    checks that lnum-element of the list exists and is an int matrix 
402  *    extracts matrix information(it,m,n,lr) 
403  *     In  : 
404  *       fname : name of calling function for error message 
405  *       topk  : stack ref for error message 
406  *       lw    : stack position 
407  *     Out : 
408  *       [it,m,n] matrix dimensions 
409  *       it : 1,2,4,11,12,14 
410  *       lr : istk(lr+i-1)   : matrix data must be properly cast 
411  *                             according to it value 
412  *------------------------------------------------------------------ */
413
414 int C2F(getlistimat)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *lr,unsigned long fname_len)
415 {
416   int nv, ili;
417
418   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
419     return FALSE;
420
421   if (*lnum > nv) {
422     Scierror(999,_("%s: Wrong type for argument %d: List of size at least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
423     return FALSE;
424   }
425   return C2F(getimati)(fname, topk, spos, &ili,it, m, n, lr,  &c_true, lnum, fname_len);
426
427
428 /*------------------------------------------------------------------- 
429  * getimat :
430  *     check that object at position lw is an int matrix 
431  *     In  : 
432  *       fname : name of calling function for error message 
433  *       topk  : stack ref for error message 
434  *       lw    : stack position ( ``in the top sense'' )
435  *     Out : 
436  *       [it,m,n] matrix dimensions 
437  *       lr : istk(lr+i-1)= a(i)
438  *------------------------------------------------------------------- */
439
440 int C2F(getimat)(char *fname,int *topk,int *lw,int *it,int *m,int *n,int *lr,unsigned long fname_len)
441 {
442   return C2F(getimati)(fname, topk, lw,Lstk(*lw),it,m, n, lr,&c_false, &cx0, fname_len);
443 }
444
445 /*------------------------------------------------------------------- 
446  * For internal use 
447  *------------------------------------------------------------------- */
448
449 static int C2F(getimati)(char *fname,int *topk,int *spos,int *lw,int *it,int *m,int *n,int *lr,int *inlistx,int *nel,unsigned long fname_len)
450 {
451   int il;
452   il = iadr(*lw);
453   if (*istk(il ) < 0) il = iadr(*istk(il +1));
454   if (*istk(il ) != 8 ) {
455     if (*inlistx) 
456       Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Int matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
457     else 
458       Scierror(201,_("%s: Wrong type for argument %d: Real or complex matrix expected.\n"),get_fname(fname,fname_len),Rhs + (*spos - *topk));
459     return  FALSE;
460   }
461   *m = *istk(il + 1);
462   *n = *istk(il + 2);
463   *it = *istk(il + 3);
464   *lr = il+4;
465   return TRUE;
466
467
468
469 /*---------------------------------------------------------- 
470  *  listcreimat(top,numero,lw,....) 
471  *      le numero ieme element de la liste en top doit etre un matrice 
472  *      stockee a partir de Lstk(lw) 
473  *      doit mettre a jour les pointeurs de la liste 
474  *      ainsi que stk(top+1) 
475  *      si l'element a creer est le dernier 
476  *      lw est aussi mis a jour 
477  *---------------------------------------------------------- */
478
479 int C2F(listcreimat)(char *fname,int *lw,int *numi,int *stlw,int *it,int *m,int *n,int *lrs,unsigned long fname_len)
480 {
481   int ix1,il ;
482     
483   if (C2F(creimati)(fname, stlw,it, m, n, lrs, &c_true, fname_len)==FALSE)
484     return FALSE ;
485   *stlw = sadr(*lrs + memused(*it,*m * *n));
486   il = iadr(*Lstk(*lw ));
487   ix1 = il + *istk(il +1) + 3;
488   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
489   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
490   return TRUE;
491
492
493 /*---------------------------------------------------------- 
494  *  creimat :
495  *   checks that an int matrix [it,m,n] can be stored at position  lw 
496  *   <<pointers>> to real and imaginary part are returned on success
497  *   In : 
498  *     lw : position (entier) 
499  *     it : type 1,2,4,11,12,14 
500  *     m, n dimensions 
501  *   Out : 
502  *     lr : istk(lr+i-1)=> a(i)   
503  *   Side effect : if matrix creation is possible 
504  *     [it,m,n] are stored in Scilab stack 
505  *     and lr is returned 
506  *     but stk(lr+..) are unchanged 
507  *---------------------------------------------------------- */
508
509 int C2F(creimat)(char *fname,int *lw,int *it,int *m,int *n,int *lr,unsigned long fname_len)
510 {
511
512   if (*lw + 1 >= Bot) {
513     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
514     return FALSE;
515   }
516   if ( C2F(creimati)(fname, Lstk(*lw ), it, m, n, lr,&c_true, fname_len) == FALSE)
517     return FALSE ;
518   *Lstk(*lw +1) = sadr(*lr + memused(*it,*m * *n));
519   return TRUE;
520
521
522 /*--------------------------------------------------------- 
523  * internal function used by cremat and listcremat 
524  *---------------------------------------------------------- */
525
526 int C2F(creimati)(char *fname,int *stlw,int *it,int *m,int *n,int *lr,int *flagx,unsigned long fname_len)
527 {
528   int ix1;
529   int il;
530   double size =  memused(*it,((double)*m)*((double) *n));
531   il = iadr(*stlw);
532   ix1 = il + 4;
533   Err = sadr(ix1) - *Lstk(Bot );
534   if (Err > -size ) {
535     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
536     return FALSE;
537   };
538   if (*flagx) {
539     *istk(il ) = 8;
540     /* if m*n=0 then both dimensions are to be set to zero */
541     *istk(il + 1) = Min(*m , *m * *n);
542     *istk(il + 2) = Min(*n ,*m * *n);
543     *istk(il + 3) = *it;
544   }
545   ix1 = il + 4;
546   *lr = ix1;
547   return TRUE;
548
549
550
551 /**********************************************************************
552  * BOOLEAN MATRICES 
553  **********************************************************************/
554
555 /*------------------------------------------------------------------ 
556  * getlistbmat : 
557  *    checks that spos object is a list 
558  *    checks that lnum-element of the list exists and is a boolean matrix 
559  *    extracts matrix information(m,n,lr) 
560  *------------------------------------------------------------------ */
561
562 int C2F(getlistbmat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *lr,unsigned long fname_len)
563 {
564   int nv;
565   int ili;
566
567   if (C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len)== FALSE)
568     return FALSE ;
569
570   if (*lnum > nv) {
571     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
572     return FALSE ;
573   }
574   
575   return C2F(getbmati)(fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len);
576
577
578 /*------------------------------------------------------------------- 
579  * getbmat :
580  *     check that object at position lw is a boolean matrix 
581  *     In  : 
582  *       fname : name of calling function for error message 
583  *       lw    : stack position 
584  *     Out : 
585  *       [m,n] matrix dimensions 
586  *       lr : istk(lr+i-1)= a(i)
587  *------------------------------------------------------------------- */
588
589 int C2F(getbmat)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
590 {
591   return C2F(getbmati)(fname, topk, lw, Lstk(*lw ), m, n, lr, &c_false, &cx0, fname_len);
592 }
593
594 /*------------------------------------------------------------------ 
595  * matbsize :
596  *    like getbmat but here m,n are given on entry 
597  *    and we check that matrix is of size (m,n) 
598  *------------------------------------------------------------------ */
599
600 int C2F(matbsize)(char *fname,int *topk,int *lw,int *m,int *n,unsigned long fname_len)
601 {
602   int m1, n1, lr;
603   if ( C2F(getbmat)(fname, topk, lw, &m1, &n1, &lr, fname_len) == FALSE)
604     return FALSE;
605   if (*m != m1 || *n != n1) {
606     Scierror(205,_("%s: Wrong size for argument %d: (%d,%d) expected.\n"),get_fname(fname,fname_len),Rhs + (*lw - *topk),*m,*n);
607     return FALSE;
608   }
609   return TRUE;
610
611
612 /*------------------------------------------------------------------- 
613  * For internal use 
614  *------------------------------------------------------------------- */
615
616 static int C2F(getbmati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *lr,int *inlistx,int *nel,unsigned long fname_len)
617 {
618   int il;
619
620   il = iadr(*lw);
621   if (*istk(il ) < 0)    il = iadr(*istk(il +1));
622
623   if (*istk(il ) != 4) {
624     if (*inlistx) 
625       Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Boolean matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
626     else 
627       Scierror(208,_("%s: Wrong type for argument %d: Boolean matrix expected.\n"),get_fname(fname,fname_len),
628                Rhs + (*spos - *topk));
629     return FALSE;
630   };
631   *m = *istk(il +1);
632   *n = *istk(il +2);
633   *lr = il + 3;
634   return  TRUE;
635
636
637 /*------------------------------------------------== 
638  *      listcrebmat(top,numero,lw,....) 
639  *      le numero ieme element de la liste en top doit etre un bmatrice 
640  *      stockee a partir de Lstk(lw) 
641  *      doit mettre a jour les pointeurs de la liste 
642  *      ainsi que stk(top+1) 
643  *      si l'element a creer est le dernier 
644  *      lw est aussi mis a jour 
645  *---------------------------------------------------------- */
646
647 int C2F(listcrebmat)(char *fname,int *lw,int *numi,int *stlw,int *m,int *n,int *lrs,unsigned long fname_len)
648 {
649   int ix1;
650   int il;
651
652   if ( C2F(crebmati)(fname, stlw, m, n, lrs, &c_true, fname_len)== FALSE) 
653     return FALSE;
654
655   ix1 = *lrs + *m * *n + 2;
656   *stlw = sadr(ix1);
657   il = iadr(*Lstk(*lw ));
658   ix1 = il + *istk(il +1) + 3;
659   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
660   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
661   return TRUE;
662 }
663
664 /*---------------------------------------------------------- 
665  *  crebmat :
666  *   checks that a boolean matrix [m,n] can be stored at position  lw 
667  *   <<pointers>> to data is returned on success
668  *   In : 
669  *     lw : position (entier) 
670  *     m, n dimensions 
671  *   Out : 
672  *     lr : istk(lr+i-1)= a(i) 
673  *   Side effect : if matrix creation is possible 
674  *     [m,n] are stored in Scilab stack 
675  *     and lr is  returned 
676  *     but istk(lr+..) is unchanged 
677  *---------------------------------------------------------- */
678
679 int C2F(crebmat)(char *fname,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
680 {
681   int ix1;
682   
683   if (*lw + 1 >= Bot) {
684     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
685     return FALSE ;
686   }
687
688   if ( C2F(crebmati)(fname, Lstk(*lw ), m, n, lr, &c_true, fname_len)== FALSE)
689     return FALSE ;
690
691   ix1 = *lr + *m * *n + 2;
692   *Lstk(*lw +1) = sadr(ix1);
693   return TRUE;
694
695
696 /*-------------------------------------------------
697  * Similar to crebmat but we only check for space 
698  * no data is stored 
699  *-------------------------------------------------*/
700
701 int C2F(fakecrebmat)(int *lw,int *m,int *n,int *lr) 
702 {
703   if (*lw + 1 >= Bot) {
704         Scierror(18,_("%s: Too many names.\n"),"fakecrebmat");
705     return FALSE;
706   }
707   if ( C2F(crebmati)("crebmat", Lstk(*lw ), m, n, lr, &c_false, 7L)== FALSE)
708     return FALSE ;
709   *Lstk(*lw +1) = sadr( *lr + *m * *n + 2);
710   return TRUE;
711
712
713 /*--------------------------------------------------------- 
714  * internal function used by crebmat and listcrebmat 
715  *---------------------------------------------------------- */
716
717 static int C2F(crebmati)(char *fname,int *stlw,int *m,int *n,int *lr,int *flagx,unsigned long fname_len)
718 {
719   double size = ((double) *m) * ((double) *n) ;
720   int il;
721   il = iadr(*stlw);
722   Err = il + 3  - iadr(*Lstk(Bot ));
723   if (Err > -size ) {
724     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
725     return FALSE;
726   }
727   if (*flagx) {
728     *istk(il ) = 4;
729     /*     si m*n=0 les deux dimensions sont mises a zero. */
730     *istk(il + 1) = Min(*m , *m * *n);
731     *istk(il + 2) = Min(*n,*m * *n);
732   }
733   *lr = il + 3;
734   return TRUE;
735 }
736
737 /**********************************************************************
738  * SPARSE MATRICES 
739  *       [it,m,n,nel,mnel,icol,lr,lc] 
740  *       nel : number of non nul elements 
741  *       istk(mnel+i-1), i=1,m : number of non nul elements of row i 
742  *       non nul elements are stored in row order as follows:
743  *       istk(icol+j-1) ,j=1,nel, column of the j-th non null element 
744  *       stk(lr + j-1)  ,j=1,nel, real value of the j-th non null element 
745  *       stk(lc + j-1)  ,j=1,nel, imag. value of the j-th non null element 
746  *       lc is to be used only if matrix is complex (it==1)
747  **********************************************************************/
748
749 /*------------------------------------------------------------------ 
750  * getlistsparse : 
751  *    checks that spos object is a list 
752  *    checks that lnum-element of the list exists and is a sparse matrix 
753  *    extracts matrix information(it,m,n,nel,mnel,icol,lr,lc) 
754  *------------------------------------------------------------------ */
755
756 int C2F(getlistsparse)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,unsigned long fname_len)
757 {
758   int  nv;
759   int ili;
760
761   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE) 
762     return FALSE ;
763   
764   if (*lnum > nv) {
765     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),
766              get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
767     return FALSE;
768   }
769
770   return C2F(getsparsei)(fname, topk, spos, &ili, it, m, n, nel, mnel, icol, lr, lc, &c_true, lnum, fname_len);
771
772
773
774 /*------------------------------------------------------------------- 
775  * getsparse :
776  *     check that object at position lw is a sparse matrix 
777  *     In  : 
778  *       fname : name of calling function for error message 
779  *       lw    : stack position 
780  *     Out : 
781  *       [it,m,n,nel,mnel,icol,lr,lc] matrix dimensions 
782  *------------------------------------------------------------------- */
783
784 int C2F(getsparse)(char *fname,int *topk,int *lw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,unsigned long fname_len)
785 {
786   return C2F(getsparsei)(fname, topk, lw, Lstk(*lw ), it, m, n, nel, mnel, icol, lr, lc, &c_false, &cx0, fname_len);
787 }
788
789 /*------------------------------------------------------------------- 
790  * getrsparse : lie getsparse but we check for a real matrix  
791  *------------------------------------------------------------------- */
792
793 int C2F(getrsparse)(char *fname, int *topk, int *lw, int *m, int *n,  int *nel, int *mnel, int *icol, int *lr,unsigned long fname_len)
794 {
795   int lc, it;  
796   if ( C2F(getsparse)(fname, topk, lw, &it, m, n, nel, mnel, icol, lr, &lc, fname_len) == FALSE ) 
797     return FALSE;
798
799   if (it != 0) {
800     Scierror(202,_("%s: Wrong type for argument %d: Real matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
801     return FALSE;
802   }
803   return TRUE;
804 }
805
806 /*--------------------------------------- 
807  * internal function for getmat and listgetmat 
808  *--------------------------------------- */
809
810 static int C2F(getsparsei)(char *fname,int *topk,int *spos,int *lw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,int *inlistx,int *nellist,unsigned long fname_len)
811 {
812   int il;
813
814   il = iadr(*lw);
815   if (*istk(il ) < 0)   il = iadr(*istk(il +1));
816
817   if (*istk(il ) != sci_sparse) {
818     if (*inlistx) 
819       Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Sparse matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nellist);
820     else 
821       Scierror(999,_("%s: Wrong type for argument %d: Sparse matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk));
822     return FALSE;
823   }
824   *m   = *istk(il + 1);
825   *n   = *istk(il + 2);
826   *it  = *istk(il + 3);
827   *nel = *istk(il + 4);
828   *mnel = il + 5;
829   *icol = il + 5 + *m;
830   *lr = sadr(il + 5 + *m + *nel);
831   if (*it == 1)  *lc = *lr + *nel;
832   return TRUE;
833
834
835 /*---------------------------------------------------------- 
836  *      le numero ieme element de la liste en top doit etre une matrice 
837  *      sparse stockee a partir de Lstk(lw) 
838  *      doit mettre a jour les pointeurs de la liste 
839  *      ainsi que stk(top+1) 
840  *      si l'element a creer est le dernier 
841  *      lw est aussi mis a jour 
842  * 
843  *---------------------------------------------------------- */
844
845
846 int C2F(listcresparse)(char *fname,int *lw,int *numi,int *stlw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lrs,int *lcs,unsigned long fname_len)
847 {
848   int ix1,il;
849
850   if (C2F(cresparsei)(fname, stlw, it, m, n, nel, mnel, icol, lrs, lcs, fname_len)== FALSE) 
851     return FALSE ;
852
853   *stlw = *lrs + *nel * (*it + 1);
854   il = iadr(*Lstk(*lw ));
855   ix1 = il + *istk(il +1) + 3;
856   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
857   if (*numi == *istk(il +1)) {
858     *Lstk(*lw +1) = *stlw;
859   }
860   return TRUE;
861
862
863 /*---------------------------------------------------------- 
864  *  cresparse :
865  *   checks that a sparse matrix [it,m,n,nel,mnel,icol] can be stored at position  lw 
866  *   <<pointers>> to real and imaginary part are returned on success
867  *   In : 
868  *     lw : position (entier) 
869  *     it : type 0 ou 1 
870  *     m, n,nel  dimensions 
871  *   Out : 
872  *     mnel,icol,lr,lc 
873  *   Side effect : if matrix creation is possible 
874  *     [it,m,n,nel] are stored in Scilab stack 
875  *     and mnel,icol,lr and lc are returned 
876  *     but data is unchanged 
877  *---------------------------------------------------------- */
878
879 int C2F(cresparse)(char *fname,int *lw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,unsigned long fname_len)
880 {
881   if (*lw + 1 >= Bot) {
882     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
883     return FALSE ;
884   }
885   
886   if ( C2F(cresparsei)(fname, Lstk(*lw ), it, m, n, nel, mnel, icol, lr, lc, fname_len)
887        == FALSE) 
888     return FALSE ;
889   *Lstk(*lw +1) = *lr + *nel * (*it + 1);
890   return TRUE;
891
892
893
894 /*--------------------------------------------------------- 
895  * internal function used by cremat and listcremat 
896  *---------------------------------------------------------- */
897
898 static int C2F(cresparsei)(char *fname,int *stlw,int *it,int *m,int *n,int *nel,int *mnel,int *icol,int *lr,int *lc,unsigned long fname_len)
899 {
900   int il,ix1;
901
902   il = iadr(*stlw);
903   ix1 = il + 5 + *m + *nel;
904   Err = sadr(ix1) + *nel * (*it + 1) - *Lstk(Bot );
905   if (Err > 0) {
906     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
907     return FALSE;
908   };
909   *istk(il ) = sci_sparse;
910   /*   if m*n=0 the 2 dims are set to zero */
911   if ( *m == 0  ||  *n == 0 )  /* use this new test in place of the product m * n (bruno) */
912     {
913       *istk(il + 1) = 0; *istk(il + 2) = 0;
914     }
915   else
916     {
917       *istk(il + 1) = *m; *istk(il + 2) = *n;
918     }
919   *istk(il + 3) = *it;
920   *istk(il + 4) = *nel;
921   *mnel = il + 5;
922   *icol = il + 5 + *m;
923   ix1 = il + 5 + *m + *nel;
924   *lr = sadr(ix1);
925   *lc = *lr + *nel;
926   return TRUE;
927
928
929 /**********************************************************************
930  * VECTORS  
931  **********************************************************************/
932
933 /*------------------------------------------------------------------ 
934  * getlistvect : 
935  *    checks that spos object is a list 
936  *    checks that lnum-element of the list exists and is a vector 
937  *    extracts vector information(it,m,n,lr,lc) 
938  *------------------------------------------------------------------ */
939
940 int C2F(getlistvect)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
941 {
942   if (C2F(getlistmat)(fname, topk, spos, lnum, it, m, n, lr, lc, fname_len)== FALSE) 
943     return FALSE;
944
945   if (*m != 1 && *n != 1) {
946     Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Vector expected.\n"),get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum);
947     return  FALSE;
948   }
949   return TRUE;
950
951
952 /*------------------------------------------------------------------- 
953  * getvect :
954  *     check that object at position lw is a vector 
955  *     In  : 
956  *       fname : name of calling function for error message 
957  *       lw    : stack position 
958  *     Out : 
959  *       [it,m,n] matrix dimensions 
960  *       lr : stk(lr+i-1)= real(a(i)) 
961  *       lc : stk(lc+i-1)= imag(a(i)) exists only if it==1 
962  *------------------------------------------------------------------- */
963
964 int C2F(getvect)(char *fname,int *topk,int *lw,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
965 {
966   if ( C2F(getmat)(fname, topk, lw, it, m, n, lr, lc, fname_len) == FALSE) 
967     return FALSE;
968
969   if (*m != 1 && *n != 1) {
970     Scierror(214,_("%s: Wrong type for argument %d: Vector expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
971     return FALSE;
972   };
973   return  TRUE;
974 }
975
976
977 /*------------------------------------------------------------------ 
978  * getrvect : like getvect but we expect a real vector 
979  *------------------------------------------------------------------ */
980
981 int C2F(getrvect)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
982 {
983   if ( C2F(getrmat)(fname, topk, lw, m, n, lr, fname_len)  == FALSE)
984     return FALSE;
985
986   if (*m != 1 && *n != 1) {
987     Scierror(203,_("%s: Wrong type for argument %d: Real vector expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
988     return FALSE;
989   }
990   return TRUE ;
991 }
992
993 /*------------------------------------------------------------------ 
994  * vectsize :
995  *    like getvect but here n is given on entry 
996  *    and we check that vector is of size (n) 
997  *------------------------------------------------------------------ */
998
999 int C2F(vectsize)(char *fname,int *topk,int *lw,int *n,unsigned long fname_len)
1000 {
1001   int m1, n1, lc, lr, it1;
1002
1003   if ( C2F(getvect)(fname, topk, lw, &it1, &m1, &n1, &lr, &lc, fname_len) == FALSE) 
1004     return FALSE;
1005
1006   if (*n != m1 * n1) {
1007     Scierror(206,_("%s: Wrong size for argument %d: %d expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk), *n);
1008     return FALSE;
1009   }
1010   return TRUE;
1011
1012
1013 /**********************************************************************
1014  * SCALAR   
1015  **********************************************************************/
1016
1017 /*------------------------------------------------------------------ 
1018  *     getlistscalar : recupere un scalaire 
1019  *------------------------------------------------------------------ */
1020
1021 int C2F(getlistscalar)(char *fname,int *topk,int *spos,int *lnum,int *lr,unsigned long fname_len)
1022 {
1023   int m, n;
1024   int lc, it, nv;
1025   int ili;
1026   
1027   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1028     return FALSE;
1029
1030   if (*lnum > nv) {
1031     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),
1032              get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
1033     return FALSE;
1034   }
1035   
1036   if ( C2F(getmati)(fname, topk, spos, &ili, &it, &m, &n, lr, &lc, &c_true, lnum, fname_len)
1037        == FALSE)
1038     return FALSE;
1039
1040   if (m * n != 1) {
1041     Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Scalar expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
1042     return FALSE;
1043   }
1044   return TRUE;
1045 }
1046
1047 /*------------------------------------------------------------------ 
1048  * getscalar :
1049  *     check that object at position lw is a scalar 
1050  *     In  : 
1051  *       fname : name of calling function for error message 
1052  *       lw    : stack position 
1053  *     Out : 
1054  *       lr : stk(lr)= scalar_value 
1055  *------------------------------------------------------------------ */
1056
1057 int C2F(getscalar)(char *fname,int *topk,int *lw,int *lr,unsigned long fname_len)
1058 {
1059   int m, n;
1060
1061   if ( C2F(getrmat)(fname, topk, lw, &m, &n, lr, fname_len) == FALSE) 
1062     return  FALSE;
1063
1064   if (m * n != 1) {
1065     Scierror(204,_("%s: Wrong type for argument %d: Scalar, '%s' or '%s' expected.\n"),get_fname(fname,fname_len),Rhs + (*lw - *topk), "min","max");
1066     return FALSE ; 
1067   };
1068   return TRUE;
1069
1070
1071 /**********************************************************************
1072  * STRING and string Matrices 
1073  **********************************************************************/
1074
1075 /*------------------------------------------------------------------ 
1076  * getlistsmat : 
1077  *    checks that spos object is a list 
1078  *    checks that lnum-element of the list exists and is a string matrix 
1079  *    extracts string matrix information in m,n and (ix,j)-th string in lr nlr
1080  *     In  : 
1081  *       fname : name of calling function for error message 
1082  *       topk  : stack ref for error message 
1083  *       spos  : stack position 
1084  *       lnum  : element position in the list
1085  *       ix,j  : indices of the requested element 
1086  *     Out : 
1087  *       [m,n] : lnum smatrix dimensions 
1088  *       lr  : istk(lr+i-1) gives string(ix,j) interbal codes 
1089  *       nlr : length of (ix,j)-th string 
1090  *------------------------------------------------------------------ */
1091
1092 int C2F(getlistsmat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *ix,int *j,int *lr,int *nlr,unsigned long fname_len)
1093 {
1094   int nv, ili;
1095
1096   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1097     return FALSE;
1098
1099   if (*lnum > nv) {
1100     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),
1101              get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
1102     return FALSE;
1103   }
1104   return C2F(getsmati)(fname, topk, spos, &ili,  m, n, ix,j, lr, nlr, &c_true, lnum, fname_len);
1105
1106
1107 /*------------------------------------------------------------------- 
1108  * getsmat :
1109  *     check that object at position lw is a string matrix 
1110  *     In  : 
1111  *       fname : name of calling function for error message 
1112  *       lw    : stack position 
1113  *       (ix,j): indices of the string element requested 
1114  *     Out : 
1115  *       [m,n] matrix dimensions 
1116  *       lr  : istk(lr+i-1) gives string(ix,j) internal codes 
1117  *       nlr : length of (ix,j)-th string 
1118  * Note : getsmat can be used to get a(1,1) and check that a is a string matrix 
1119  *        then other elements can be accessed through getsimat 
1120  *------------------------------------------------------------------- */
1121
1122 int C2F(getsmat)(char *fname,int *topk,int *lw,int *m,int *n,int *ix,int *j,int *lr,int *nlr,unsigned long fname_len)
1123 {
1124   return C2F(getsmati)(fname, topk, lw, Lstk(*lw), m, n, ix,j , lr ,nlr,  &c_false, &cx0, fname_len);
1125 }
1126
1127 /*------------------------------------------------------------------ 
1128  * getsimat :
1129  *     In  : 
1130  *       fname : name of calling function for error message 
1131  *       lw    : stack position 
1132  *       (ix,j): indices of the string element requested 
1133  *     Out : 
1134  *       [m,n] matrix dimensions 
1135  *       lr  : istk(lr+i-1) gives string(ix,j) internal codes 
1136  *       nlr : length of (ix,j)-th string 
1137  * Note : like getsmat but do not check that object is a string matrix 
1138  *------------------------------------------------------------------- */
1139
1140 int C2F(getsimat)(char *fname,int *topk,int *lw,int *m,int *n,int *ix,int *j,int *lr,int *nlr,unsigned long fname_len)
1141 {
1142   return C2F(getsimati)(fname, topk, lw, Lstk(*lw), m, n, ix,j , lr ,nlr,  &c_false, &cx0, fname_len);
1143 }
1144
1145 /*--------------------------------------------------------------------------
1146  * getlistwsmat : 
1147  *    similar to getlistsmat but returned values are different 
1148  *       ilr  : 
1149  *       ilrd : 
1150  *    ilr and ilrd : internal coded versions of the strings 
1151  *    which can be converted to C with ScilabMStr2CM (see stack2.c)
1152  *------------------------------------------------------------------ */
1153
1154 int C2F(getlistwsmat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *ilr,int *ilrd,unsigned long fname_len)
1155 {
1156   int nv, ili;
1157
1158   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
1159     return FALSE;
1160
1161   if (*lnum > nv) {
1162     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
1163     return FALSE;
1164   }
1165   return C2F(getwsmati)(fname, topk, spos, &ili, m, n, ilr, ilrd, &c_true, lnum, fname_len);
1166
1167
1168 /*--------------------------------------------------------------------------
1169  * getwsmat : checks for a mxn string matrix 
1170  *    similar to getsmat but returned values are different 
1171  *    ilr and ilrd : internal coded versions of the strings 
1172  *    which can be converted to C with ScilabMStr2CM (see stack2.c)
1173  *--------------------------------------------------------------------------*/
1174
1175 int C2F(getwsmat)(char *fname,int *topk,int *lw,int *m,int *n,int *ilr,int *ilrd,unsigned long fname_len)
1176 {
1177   return C2F(getwsmati)(fname, topk, lw,Lstk(*lw), m, n, ilr, ilrd, &c_false, &cx0, fname_len);
1178 }
1179
1180 /*------------------------------------------------------------------- 
1181  * For internal use 
1182  *------------------------------------------------------------------- */
1183
1184 static int C2F(getwsmati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *ilr,int *ilrd ,int *inlistx,int *nel,unsigned long fname_len)
1185 {
1186     int il;
1187     il = iadr(*lw);
1188     if (*istk(il ) < 0) il = iadr(*istk(il +1));
1189     if (*istk(il ) != sci_strings) {
1190                 if (*inlistx){
1191                         Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Matrix of strings expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
1192                 } else {
1193                         Scierror(207,_("%s: Wrong type for argument %d: Matrix of strings expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk));
1194                 }
1195                 return FALSE;
1196     }
1197     *m = *istk(il + 1);
1198     *n = *istk(il + 2);
1199     *ilrd = il + 4;
1200     *ilr =  il + 5 + *m * *n;
1201     return TRUE;
1202
1203
1204 /*------------------------------------------------------------------- 
1205  * For internal use 
1206  *------------------------------------------------------------------- */
1207
1208 static int C2F(getsmati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *ix,int *j,int *lr,int *nlr,int *inlistx,int *nel,unsigned long fname_len)
1209 {
1210   int il = iadr(*lw);
1211   if (*istk(il ) < 0) il = iadr(*istk(il +1));
1212   if (*istk(il ) != sci_strings ) {
1213           if (*inlistx) {
1214                   Scierror(999,_("%s: Wrong type for argument %d (List element: %d): String matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
1215           } else {
1216                   Scierror(201,_("%s: Wrong type for argument %d: String matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk));
1217           }
1218     return  FALSE;
1219   }
1220   C2F(getsimati)(fname, topk, spos, lw, m, n, ix,j , lr ,nlr, inlistx, nel, fname_len);
1221   return TRUE;
1222
1223
1224 int C2F(getsimati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *ix,int *j ,int *lr ,int *nlr,int *inlistx,int *nel,unsigned long fname_len)
1225 {
1226   int k, il =  iadr(*lw);
1227   if (*istk(il ) < 0) il = iadr(*istk(il +1)); 
1228   *m = *istk(il + 1);
1229   *n = *istk(il + 2);
1230   k = *ix - 1 + (*j - 1) * *m;
1231   *lr = il + 4 + *m * *n + *istk(il + 4 + k );
1232   *nlr = *istk(il + 4 + k +1) - *istk(il + 4 + k );
1233   return 0;
1234 }
1235
1236 /*---------------------------------------------------------- 
1237  *     listcresmat(top,numero,lw,....) 
1238  *     le  ieme element de la liste en top doit etre une 
1239  *     matrice stockee a partir de Lstk(lw) 
1240  *     doit mettre a jour les pointeurs de la liste 
1241  *     ainsi que Lstk(top+1) si l'element a creer est le dernier 
1242  *     lw est aussi mis a jour 
1243  *     job==1: nchar est la taille de chaque chaine de la  matrice 
1244  *     job==2: nchar est le vecteur des tailles des chaines de la 
1245  *             matrice 
1246  *     job==3: nchar est le vecteur des pointeurs sur les chaines 
1247  *             de la matrice 
1248  *---------------------------------------------------------- */
1249
1250 int C2F(listcresmat)(char *fname,int *lw,int *numi,int *stlw,int *m,int *n,int *nchar,int *job,int *ilrs,unsigned long fname_len)
1251 {
1252   int ix1;
1253   int il, sz;
1254
1255   if ( C2F(cresmati)(fname, stlw, m, n, nchar, job, ilrs, &sz, fname_len) == FALSE )
1256     return FALSE;
1257   ix1 = *ilrs + sz;
1258   *stlw = sadr(ix1);
1259   il = iadr(*Lstk(*lw ));
1260   ix1 = il + *istk(il +1) + 3;
1261   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
1262   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
1263   return TRUE;
1264
1265
1266 /*---------------------------------------------------------- 
1267  * cresmat :
1268  *   checks that a string matrix [m,n] of strings 
1269  *   (each string is of length nchar)
1270  *   can be stored at position  lw on the stack 
1271  * Note that each string can be filled with getsimat 
1272  *---------------------------------------------------------- */
1273
1274 int C2F(cresmat)(char *fname,int *lw,int *m,int *n,int *nchar,unsigned long fname_len)
1275 {
1276   int job = 1;
1277   int ix1, ilast, sz,lr ;
1278   if (*lw + 1 >= Bot) {
1279     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1280     return  FALSE;
1281   }
1282   if ( C2F(cresmati)(fname,Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE )
1283     return FALSE ;
1284   ilast = lr - 1;
1285   ix1 = ilast + *istk(ilast );
1286   *Lstk(*lw +1) = sadr(ix1);
1287   /* empty strings */
1288   if ( *nchar == 0)   *Lstk(*lw +1) += 1;
1289   return TRUE;
1290 }
1291
1292 /*------------------------------------------------------------------ 
1293  *  cresmat1 :
1294  *   checks that a string matrix [m,1] of string of length nchar[i]
1295  *   can be stored at position  lw on the stack 
1296  *   nchar : array of length m giving each string length 
1297  *  Note that each string can be filled with getsimat 
1298  *------------------------------------------------------------------ */
1299
1300 int C2F(cresmat1)(char *fname,int *lw,int *m,int *nchar,unsigned long fname_len)
1301 {
1302   int job = 2, n=1;
1303   int ix1, ilast, sz,lr ;
1304   if (*lw + 1 >= Bot) {
1305     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1306     return  FALSE;
1307   }
1308   if ( C2F(cresmati)(fname,Lstk(*lw), m, &n, nchar, &job, &lr, &sz, fname_len) == FALSE )
1309     return FALSE ;
1310   ilast = lr - 1;
1311   ix1 = ilast + *istk(ilast );
1312   *Lstk(*lw +1) = sadr(ix1);
1313   return TRUE;
1314 }
1315
1316 /*------------------------------------------------------------------ 
1317  *  cresmat2 :
1318  *   checks that a string of length nchar can be stored at position  lw 
1319  *  Out : 
1320  *     lr : istk(lr+i) give access to the internal array 
1321  *          allocated for string code 
1322  *------------------------------------------------------------------ */
1323
1324 int C2F(cresmat2)(char *fname,int *lw,int *nchar,int *lr,unsigned long fname_len)
1325 {
1326   int job = 1, n=1,m=1;
1327   int ix1, ilast, sz ;
1328   if (*lw + 1 >= Bot) {
1329    Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1330     return  FALSE;
1331   }
1332   if ( C2F(cresmati)(fname,Lstk(*lw), &m, &n, nchar, &job, lr, &sz, fname_len) == FALSE )
1333     return FALSE ;
1334
1335   ilast = *lr - 1;
1336   ix1 = ilast + *istk(ilast );
1337   *Lstk(*lw +1) = sadr(ix1);
1338   /* empty strings */
1339   if ( *nchar == 0)   *Lstk(*lw +1) += 1;
1340   *lr = ilast + *istk(ilast - 1);
1341   return TRUE;
1342
1343
1344 /*------------------------------------------------------------------ 
1345  * cresmat3 :
1346  *   Try to create a string matrix S of size mxn 
1347  *     - nchar: array of size mxn giving the length of string S(i,j)
1348  *     - buffer : a character array wich contains the concatenation 
1349  *             of all the strings 
1350  *     - lw  : stack position for string creation 
1351  *------------------------------------------------------------------ */
1352
1353 int C2F(cresmat3)(char *fname,int *lw,int *m,int *n,int *nchar,char *buffer,unsigned long fname_len,unsigned long buffer_len)
1354 {
1355   int job = 2;
1356   int ix1, ilast, sz,lr,lr1 ;
1357   if (*lw + 1 >= Bot) {
1358     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1359     return  FALSE;
1360   }
1361   if ( C2F(cresmati)(fname,Lstk(*lw), m, n, nchar, &job, &lr, &sz, fname_len) == FALSE )
1362     return FALSE ;
1363   ilast = lr - 1;
1364   ix1 = ilast + *istk(ilast );
1365   *Lstk(*lw +1) = sadr(ix1);
1366
1367   lr1 = ilast + *istk(ilast - (*m)*(*n) );
1368   C2F(cvstr)(&sz, istk(lr1), buffer, &cx0, buffer_len);
1369   return TRUE;
1370
1371
1372 /*------------------------------------------------------------------ 
1373  *     checks that an [m,1] string matrix can be stored in the 
1374  *     stack. 
1375  *     All chains have the same length nchar 
1376  *     istk(lr) --- beginning of chains 
1377  *------------------------------------------------------------------ */
1378
1379 int C2F(cresmat4)(char *fname,int *lw,int *m,int *nchar,int *lr,unsigned long fname_len)
1380 {
1381   int ix1,ix, ilast, il, nnchar, kij, ilp;
1382   if (*lw + 1 >= Bot) {
1383     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1384     return FALSE;
1385   }
1386   nnchar = 0;
1387   ix1 = *m;
1388   for (ix = 1; ix <= ix1; ++ix) nnchar += *nchar;
1389   il = iadr(*Lstk(*lw ));
1390   ix1 = il + 4 + (nnchar + 1) * *m;
1391   Err = sadr(ix1) - *Lstk(Bot );
1392   if (Err > 0) {
1393     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1394     return FALSE;
1395   } 
1396   *istk(il ) = sci_strings;
1397   *istk(il + 1) = *m;
1398   *istk(il + 2) = 1;
1399   *istk(il + 3) = 0;
1400   ilp = il + 4;
1401   *istk(ilp ) = 1;
1402   ix1 = ilp + *m;
1403   for (kij = ilp + 1; kij <= ix1; ++kij) {
1404     *istk(kij ) = *istk(kij - 1) + *nchar;
1405   }
1406   ilast = ilp + *m;
1407   ix1 = ilast + *istk(ilast );
1408   *Lstk(*lw +1) = sadr(ix1);
1409   *lr = ilast + 1;
1410   return TRUE;
1411 }
1412
1413 /*--------------------------------------------------------- 
1414  * internal function used by cresmat cresmat1 and listcresmat 
1415  * job : 
1416  *   case 1: all string are of same length (nchar) in the matrix 
1417  *   case 2: nchar is a vector which gives string lengthes 
1418  *   case 3: ? 
1419  *---------------------------------------------------------- */
1420
1421 int C2F(cresmati)(char *fname,int *stlw,int *m,int *n,int *nchar,int *job,int *lr,int *sz,unsigned long fname_len)
1422 {
1423   int ix1, ix, il, kij, ilp, mn= (*m)*(*n);
1424   il = iadr(*stlw);
1425  
1426  /* compute the size of chains */ 
1427   *sz = 0;
1428   switch ( *job ) 
1429     {
1430     case 1 : *sz = mn * nchar[0];   break;
1431     case 2 : for (ix = 0 ; ix < mn ; ++ix) *sz += nchar[ix];  break;
1432     case 3 : *sz = nchar[mn] - 1;  break;
1433     }
1434   /* check the stack for space */
1435   ix1 = il + 4 + mn + 1 + *sz;
1436   Err = sadr(ix1) - *Lstk(Bot );
1437   if (Err > 0) {
1438     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1439     return FALSE;
1440   };
1441   
1442   *istk(il ) = sci_strings;
1443   *istk(il + 1) = *m;
1444   *istk(il + 2) = *n;
1445   *istk(il + 3) = 0;
1446   ilp = il + 4;
1447   *istk(ilp ) = 1;
1448   switch ( *job ) 
1449     {
1450     case 1 :
1451       ix1 = mn  + ilp;
1452       for (kij = ilp + 1; kij <= ix1; ++kij) {
1453         *istk(kij) = *istk(kij - 1) + nchar[0];
1454       }
1455       break;
1456     case 2 :
1457       ix = 0;
1458       ix1 = mn + ilp;
1459       for (kij = ilp + 1; kij <= ix1; ++kij) {
1460         *istk(kij ) = *istk(kij - 2 +1) + nchar[ix]; 
1461         ++ix;
1462       }
1463       break;
1464     case 3 :
1465       {
1466         ix1 = mn + 1;
1467         C2F(icopy)(&ix1, nchar, &cx1, istk(ilp ), &cx1);
1468       }
1469     }
1470   *lr = ilp + mn + 1;
1471   return TRUE;
1472 }
1473
1474 /*------------------------------------------------------------------ 
1475  * Try to create a string matrix S of size mxn 
1476  *     - m is the number of rows of Matrix S 
1477  *     - n is the number of colums of Matrix S 
1478  *     - Str : a null terminated array of strings char **Str assumed 
1479  *             to contain at least m*n strings 
1480  *     - lw  : where to create the matrix on the stack 
1481  *------------------------------------------------------------------ */
1482
1483 int cre_smat_from_str_i(char *fname, int *lw, int *m, int *n, char *Str[],unsigned long fname_len, int *rep)
1484 {
1485   int ix1, ix, ilast, il, nnchar, lr1, kij, ilp;
1486   int *pos;
1487
1488   nnchar = 0;
1489   if (Str) for (ix = 0 ; ix < (*m)*(*n) ; ++ix) nnchar += (int) strlen(Str[ix]);
1490   else nnchar = 0;
1491   
1492   il = iadr(*lw);
1493   ix1 = il + 4 + (nnchar + 1) + (*m * *n + 1);
1494   Err = sadr(ix1) - *Lstk(Bot );
1495   if (Err > 0) {
1496     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1497     return  FALSE;
1498   } ;
1499   *istk(il ) = sci_strings;
1500   *istk(il + 1) = *m;
1501   *istk(il + 2) = *n;
1502   *istk(il + 3) = 0;
1503   ilp = il + 4;
1504   *istk(ilp ) = 1;
1505   ix = 0;
1506   ix1 = ilp + *m * *n;
1507   for (kij = ilp + 1; kij <= ix1; ++kij) 
1508   {
1509           if (Str)
1510           {
1511                 *istk(kij ) = *istk(kij - 1) + (int)strlen(Str[ix]);
1512                 ++ix;
1513           }
1514           else
1515           {
1516                 *istk(kij ) = *istk(kij - 1) + 0;
1517                 ++ix;
1518           }
1519   }
1520   ilast = ilp + *m * *n;
1521   lr1 = ilast + *istk(ilp );
1522   pos = istk(lr1);
1523   if (Str)
1524   {
1525           for ( ix = 0 ; ix < (*m)*(*n) ; ix++) 
1526           {
1527                   int l = (int)strlen(Str[ix]);
1528                   C2F(cvstr)(&l, pos, Str[ix], &cx0, l);
1529                   pos += l;
1530           }
1531   }
1532   ix1 = ilast + *istk(ilast );
1533   *rep = sadr(ix1);
1534   return TRUE;
1535
1536
1537
1538 int cre_smat_from_str(char *fname,int *lw,int *m,int *n,char *Str[],unsigned long fname_len)
1539 {
1540   int rep;
1541   
1542   if (*lw + 1 >= Bot) {
1543     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1544     return FALSE;
1545   }
1546
1547   if ( cre_smat_from_str_i(fname, Lstk(*lw ), m, n, Str, fname_len,&rep)== FALSE )
1548     return FALSE;
1549   *Lstk(*lw+1) = rep;
1550   return TRUE;
1551
1552
1553
1554 int cre_listsmat_from_str(char *fname,int *lw,int *numi,int *stlw,int *m,int *n,char *Str[],unsigned long fname_len )
1555 {
1556   int rep,ix1,il;
1557   if ( cre_smat_from_str_i(fname, stlw, m, n, Str, fname_len,&rep)== FALSE )
1558     return FALSE;
1559   *stlw = rep;
1560   il = iadr(*Lstk(*lw ));
1561   ix1 = il + *istk(il +1) + 3;
1562   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
1563   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
1564   return TRUE;
1565
1566
1567
1568 /*------------------------------------------------------------------ 
1569  * Try to create a sparse matrix S of size mxn 
1570  *     - m is the number of rows of Matrix S 
1571  *     - n is the number of colums of Matrix S 
1572  *     - Str : a null terminated array of strings char **Str assumed 
1573  *             to contain at least m*n strings 
1574  *     - lw  : where to create the matrix on the stack 
1575  *------------------------------------------------------------------ */
1576
1577 int cre_sparse_from_ptr_i(char *fname, int *lw, int *m, int *n, SciSparse *S, unsigned long fname_len,  int *rep)
1578 {
1579   double size = (double) ( (S->nel)*(S->it + 1) );
1580
1581   int ix1,  il, lr, lc;
1582   int cx1l=1;
1583   il = iadr(*lw);
1584
1585   ix1 = il + 5 + *m + S->nel;
1586   Err = sadr(ix1)  - *Lstk(Bot );
1587   if (Err > -size ) {
1588     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1589     return  FALSE;
1590   } ;
1591   *istk(il ) = sci_sparse;
1592   /* note: code sligtly modified (remark of C. Deroulers in the newsgroup) */
1593   if ( (*m == 0)  |  (*n == 0) ) {
1594       *istk(il + 1) = 0; 
1595       *istk(il + 2) = 0;
1596   } else {
1597     *istk(il + 1) = *m; 
1598     *istk(il + 2) = *n;
1599   }
1600   /* end of the modified code */
1601   *istk(il + 3) = S->it;
1602   *istk(il + 4) = S->nel;
1603   C2F(icopy)(&S->m, S->mnel, &cx1l, istk(il+5 ), &cx1l);
1604   C2F(icopy)(&S->nel, S->icol, &cx1l, istk(il+5+*m ), &cx1l);
1605   ix1 = il + 5 + *m + S->nel;
1606   lr = sadr(ix1);
1607   lc = lr + S->nel;
1608   C2F(dcopy)(&S->nel, S->R, &cx1l, stk(lr), &cx1l);
1609   if ( S->it == 1) 
1610     C2F(dcopy)(&S->nel, S->I, &cx1l, stk(lc), &cx1l);
1611   *rep = lr + S->nel*(S->it+1);
1612   return TRUE;
1613
1614
1615
1616 int cre_sparse_from_ptr(char *fname,int *lw,int *m,int *n,SciSparse *Str,unsigned long fname_len )
1617 {
1618   int rep;
1619   if (*lw + 1 >= Bot) {
1620     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1621     return FALSE;
1622   }
1623
1624   if ( cre_sparse_from_ptr_i(fname, Lstk(*lw ), m, n, Str, fname_len,&rep)== FALSE )
1625     return FALSE;
1626   *Lstk(*lw+1) = rep;
1627   return TRUE;
1628
1629
1630
1631 int cre_listsparse_from_ptr(char *fname,int *lw,int *numi,int *stlw,int *m,int *n,SciSparse *Str,unsigned long fname_len )
1632 {
1633   int rep,ix1,il;
1634   if ( cre_sparse_from_ptr_i(fname, stlw, m, n, Str, fname_len,&rep)== FALSE )
1635     return FALSE;
1636   *stlw = rep;
1637   il = iadr(*Lstk(*lw ));
1638   ix1 = il + *istk(il +1) + 3;
1639   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
1640   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
1641   return TRUE;
1642
1643
1644
1645
1646 /*------------------------------------------------------------------ 
1647  * TODO : add comments
1648  * listcrestring 
1649  *------------------------------------------------------------------ */
1650
1651 int C2F(listcrestring)(char *fname,int *lw,int *numi,int *stlw,int *nch,int *ilrs,unsigned long fname_len)
1652 {
1653   int ix1, il ;
1654
1655   if ( C2F(crestringi)(fname, stlw, nch, ilrs, fname_len) == FALSE )
1656     return FALSE;
1657
1658   ix1 = *ilrs - 1 + *istk(*ilrs - 2 +1);
1659   *stlw = sadr(ix1);
1660   il = iadr(*Lstk(*lw ));
1661   ix1 = il + *istk(il +1) + 3;
1662   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
1663   if (*numi == *istk(il +1)) {
1664     *Lstk(*lw +1) = *stlw;
1665   }
1666   return TRUE;
1667 }
1668
1669 /*------------------------------------------------------------------ 
1670 *     verifie que l'on peut stocker une matrice [1,1] 
1671 *     de chaine de caracteres a la position spos du stack 
1672 *     en renvoyant .true. ou .false.  suivant la reponse. 
1673 *     nchar est le nombre de caracteres que l'on veut stocker 
1674 *     Entree : 
1675 *       spos : position (entier) 
1676 *     Sortie : 
1677 *       ilrs 
1678 *------------------------------------------------------------------ */
1679
1680 int C2F(crestring)(char *fname,int *spos,int *nchar,int *ilrs,unsigned long fname_len)
1681 {
1682   int ix1;
1683   if ( C2F(crestringi)(fname, Lstk(*spos ), nchar, ilrs, fname_len) == FALSE) 
1684     return FALSE;
1685   ix1 = *ilrs + *nchar;
1686   *Lstk(*spos +1) = sadr(ix1);
1687   /* empty strings */
1688   if ( *nchar == 0)   *Lstk(*spos +1) += 1;
1689   return TRUE;
1690 }
1691
1692 /*------------------------------------------------------------------ 
1693  *     verifie que l'on peut stocker une matrice [1,1] 
1694  *     de chaine de caracteres  a la position stlw en renvoyant .true. ou .false. 
1695  *     suivant la reponse. 
1696  *     nchar est le nombre de caracteres que l'on veut stcoker 
1697  *     Entree : 
1698  *       stlw : position (entier) 
1699  *     Sortie : 
1700  *       nchar : nombre de caracteres stockable 
1701  *       lr : pointe sur  a(1,1)=istk(lr) 
1702  *------------------------------------------------------------------ */
1703
1704 int C2F(crestringi)(char *fname,int *stlw,int *nchar,int *ilrs,unsigned long fname_len)
1705 {
1706
1707   int ix1, ilast, il;
1708
1709   il = iadr(*stlw);
1710   ix1 = il + 4 + (*nchar + 1);
1711   Err = sadr(ix1) - *Lstk(Bot );
1712   if (Err > 0) {
1713     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1714     return FALSE;
1715   } ;
1716   *istk(il ) = sci_strings;
1717   *istk(il +1) = 1;
1718   *istk(il + 1 +1) = 1;
1719   *istk(il + 2 +1) = 0;
1720   *istk(il + 3 +1) = 1;
1721   *istk(il + 4 +1) = *istk(il + 3 +1) + *nchar;
1722   ilast = il + 5;
1723   *ilrs = ilast + *istk(ilast - 2 +1);
1724   return TRUE;
1725 }
1726
1727
1728 /*---------------------------------------------------------------------
1729  *  checks if we can store a string of size nchar at position lw 
1730  *---------------------------------------------------------------------*/
1731
1732 int C2F(fakecresmat2)(int *lw,int *nchar,int *lr)
1733 {
1734   static int cx17 = 17;
1735   int retval;
1736   static int ilast;
1737   static int il;
1738   il = iadr((*Lstk(*lw)));
1739   Err = sadr(il + 4 + (*nchar + 1)) - *Lstk(Bot);
1740   if (Err > 0) 
1741   {
1742     Error(cx17);
1743     retval = FALSE;
1744   }
1745   else
1746   {
1747     ilast = il + 5;
1748     *Lstk(*lw+1) = sadr(ilast + *istk(ilast));
1749     *lr = ilast + *istk(ilast - 1);
1750     retval = TRUE;
1751   }
1752   return retval;
1753 }
1754
1755 /*------------------------------------------------------------------ 
1756  *     verifie qu'il y a une matrice de chaine de caracteres en lw-1 
1757  *     et verifie que l'on peut stocker l'extraction de la jieme colonne 
1758  *     en lw : si oui l'extraction est faite 
1759  *     Entree : 
1760  *       lw : position (entier) 
1761  *       j  : colonne a extraire 
1762  *------------------------------------------------------------------ */
1763
1764 int C2F(smatj)(char *fname,int *lw,int *j,unsigned long fname_len)
1765 {
1766   int ix1, ix2;
1767   int incj;
1768   int ix, m, n;
1769   int lj, nj, lr, il1, il2, nlj;
1770   int il1j, il2p;
1771
1772   if (*lw + 1 >= Bot) {
1773     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1774     return FALSE;
1775   }
1776   ix1 = *lw - 1;
1777   ix2 = *lw - 1;
1778   
1779   if (! C2F(getsmat)(fname, &ix1, &ix2, &m, &n, &cx1, &cx1, &lr, &nlj, fname_len)) 
1780     return FALSE;
1781   if (*j > n) return FALSE;
1782   
1783   il1 = iadr(*Lstk(*lw - 2 +1));
1784   il2 = iadr(*Lstk(*lw ));
1785   /*     nombre de caracteres de la jieme colonne */
1786   incj = (*j - 1) * m;
1787   nj = *istk(il1 + 4 + incj + m ) - *istk(il1 + 4 + incj );
1788   /*     test de place */
1789   ix1 = il2 + 4 + m + nj + 1;
1790   Err = sadr(ix1) - *Lstk(Bot );
1791   if (Err > 0) {
1792     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
1793     return FALSE;
1794   }
1795   *istk(il2 ) = sci_strings;
1796   *istk(il2 +1) = m;
1797   *istk(il2 + 1 +1) = 1;
1798   *istk(il2 + 2 +1) = 0;
1799   il2p = il2 + 4;
1800   il1j = il1 + 4 + incj;
1801   *istk(il2p ) = 1;
1802   ix1 = m;
1803   for (ix = 1; ix <= ix1; ++ix) {
1804     *istk(il2p + ix ) = *istk(il2p - 1 + ix ) + *istk(il1j + ix ) - *istk(il1j + ix - 2 +1);
1805   }
1806   lj = *istk(il1 + 4 + incj ) + il1 + 4 + m * n;
1807   C2F(icopy)(&nj, istk(lj ), &cx1, istk(il2 + 4 + m +1), &cx1);
1808   ix1 = il2 + 4 + m + nj + 1;
1809   *Lstk(*lw +1) = sadr(ix1);
1810   return TRUE;
1811
1812
1813
1814 /*------------------------------------------------------------------ 
1815  *     copie la matrice de chaine de caracteres stockee en flw 
1816  *     en tlw, les verifications de dimensions 
1817  *     ne sont pas faites 
1818  *     Lstk(tlw+1) est modifie si necessaire 
1819  *------------------------------------------------------------------ */
1820
1821 int C2F(copysmat)(char *fname,int *flw,int *tlw,unsigned long fname_len)
1822 {
1823   int ix1;
1824   int dflw, fflw;
1825   int dtlw;
1826   dflw = iadr(*Lstk(*flw ));
1827   fflw = iadr(*Lstk(*flw +1));
1828   dtlw = iadr(*Lstk(*tlw ));
1829   ix1 = fflw - dflw;
1830   C2F(icopy)(&ix1, istk(dflw ), &cx1, istk(dtlw ), &cx1);
1831   *Lstk(*tlw +1) = *Lstk(*tlw ) + *Lstk(*flw +1) - *Lstk(*flw );
1832   return 0;
1833 }
1834
1835 /*------------------------------------------------------------------ 
1836  *     lw designe une matrice de chaine de caracteres 
1837  *     on veut changer la taille de la chaine (i,j) 
1838  *     et lui donner la valeur nlr 
1839  *     cette routine si (i,j) != (m,n) fixe 
1840  *     le pointeur de l'argument i+j*m +1 
1841  *     sans changer les valeurs de la matrice 
1842  *     si (i,j)=(m,n) fixe juste la longeur de la chaine 
1843  *     Entree : 
1844  *       fname : nom de la routine appellante pour le message 
1845  *       d'erreur 
1846  *       lw : position dans la pile 
1847  *       i,j : indice considere 
1848  *       m,n : taille de la matrice 
1849  *       lr  : 
1850  *------------------------------------------------------------------ */
1851
1852 int C2F(setsimat)(char *fname,int *lw,int *ix,int *j,int *nlr,unsigned long fname_len)
1853 {
1854   int k, m, il;
1855   il = iadr(*Lstk(*lw ));
1856   m = *istk(il +1);
1857   k = *ix - 1 + (*j - 1) * m;
1858   *istk(il + 4 + k +1) = *istk(il + 4 + k ) + *nlr;
1859   return 0;
1860 }
1861
1862 /**********************************************************************
1863  * LISTS
1864  **********************************************************************/
1865
1866 /*------------------------------------------------------------------- 
1867  * crelist :creation of a list with ilen elements at slw position 
1868  * cretlist:creation of a tlist with ilen elements at slw position 
1869  * cremlist:creation of an mlist with ilen elements at slw position 
1870  *    In : slw and ilen 
1871  *    Out : lw 
1872  *     first element can be stored at postion stk(lw) 
1873  * Note : elements are to be added to close the list creation 
1874  *------------------------------------------------------------------- */
1875
1876 int crelist_G(int *slw,int *ilen,int *lw,int type)
1877 {
1878   int ix1;
1879   int il;
1880   il = iadr(*Lstk(*slw ));
1881   *istk(il ) = type;
1882   *istk(il + 1) = *ilen;
1883   *istk(il + 2) = 1;
1884   ix1 = il + *ilen + 3;
1885   *lw = sadr(ix1);
1886   if (*ilen == 0) *Lstk(*lw +1) = *lw;
1887   return 0;
1888
1889
1890
1891 int C2F(crelist)(int *slw,int *ilen,int *lw)
1892 {
1893   return crelist_G(slw,ilen,lw,15);
1894
1895
1896 int C2F(cretlist)(int *slw,int *ilen,int *lw)
1897 {
1898   return crelist_G(slw,ilen,lw,16);
1899
1900
1901 int C2F(cremlist)(int *slw,int *ilen,int *lw)
1902 {
1903   return crelist_G(slw,ilen,lw,17);
1904
1905
1906
1907 /*------------------------------------------------------------------ 
1908  * lmatj : 
1909  *   checks that there's a list at position  lw-1 
1910  *   checks that the j-th element can be extracted at lw position 
1911  *   perform the extraction 
1912  *       lw : position 
1913  *       j  : element to be extracted 
1914  *------------------------------------------------------------------ */
1915
1916 int C2F(lmatj)(char *fname,int *lw,int *j,unsigned long fname_len)
1917 {
1918   int ix1, ix2;
1919   int n;
1920   int il, ilj, slj;
1921   if (*lw + 1 >= Bot) {
1922     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
1923     return FALSE;
1924   }
1925   ix1 = *lw - 1;
1926   ix2 = *lw - 1;
1927   if (! C2F(getilist)(fname, &ix1, &ix2, &n, j, &ilj, fname_len)) 
1928     return FALSE;
1929   if (*j > n)       return FALSE;
1930   /*     a ameliorer */
1931   il = iadr(*Lstk(*lw - 2 +1));
1932   ix1 = il + 3 + n;
1933   slj = sadr(ix1) + *istk(il + 2 + (*j - 1) ) - 1;
1934   n = *istk(il + 2 + *j ) - *istk(il + 2 + (*j - 1) );
1935   Err = *Lstk(*lw ) + n - *Lstk(Bot );
1936   if (Err > 0) return FALSE;
1937   C2F(scidcopy)(&n, stk(slj ), &cx1, stk(*Lstk(*lw ) ), &cx1);
1938   *Lstk(*lw +1) = *Lstk(*lw ) + n;
1939   return TRUE;
1940
1941
1942 /*------------------------------------------------
1943  *     renvoit .true. si l'argument en lw est une liste 
1944  *     Entree : 
1945  *      fname : nom de la routine appellante pour le message 
1946  *          d'erreur 
1947  *      lw : position ds la pile 
1948  *      i  : element demande 
1949  *     Sortie : 
1950  *      n  : nombre d'elements ds la liste 
1951  *      ili : le ieme element commence en istk(iadr(ili)) 
1952  *     ==> pour recuperer un argument il suffit 
1953  *     de faire un lk=Lstk(top);Lstk(top)=ili; getmat(...,top,...);stk(top)=lk 
1954  *------------------------------------------------*/
1955
1956 int C2F(getilist)(char *fname,int *topk,int *lw,int *n,int *ix,int *ili,unsigned long fname_len)
1957 {
1958   int ix1;
1959   int itype, il;
1960
1961   il = iadr(*Lstk(*lw ));
1962   if (*istk(il ) < 0) {
1963     il = iadr(*istk(il +1));
1964   }
1965
1966   itype = *istk(il );
1967   if (itype < sci_list || itype > sci_mlist) {
1968     Scierror(210,_("%s: Wrong type for argument %d: List expected.\n"),get_fname(fname,fname_len) , Rhs + (*lw - *topk));
1969     return FALSE;
1970   }
1971   *n = *istk(il +1);
1972   if (*ix <= *n) {
1973     ix1 = il + 3 + *n;
1974     *ili = sadr(ix1) + *istk(il + 2 + (*ix - 1) ) - 1;
1975   } else {
1976     *ili = 0;
1977   }
1978   return TRUE;
1979
1980
1981 /**********************************************************************
1982  * POLYNOMS 
1983  **********************************************************************/
1984
1985 /*------------------------------------------------
1986 *     renvoit .true. si l'argument en lw est une matrice de polynome 
1987 *             sinon appelle error et renvoit .false. 
1988 *     Entree : 
1989 *       fname : nom de la routine appellante pour le message 
1990 *       d'erreur 
1991 *       lw    : position ds la pile 
1992 *     Sortie 
1993 *       [it,m,n] caracteristiques de la matrice 
1994 *       name : nom de la variable muette ( character*4) 
1995 *       namel : taille de name <=4 ( uncounting trailling blanks) 
1996 *       soit lij=istk(ilp+(i-1)+(j-1)*m) 
1997 *       alors le degre zero de l'elements (i,j) est en 
1998 *       stk(lr+lij) (partie reelle ) et stk(lc+lij) (imag) 
1999 *       le degre de l'elt (i,j)= l(i+1)j - lij -1 
2000 *      implicit undefined (a-z) 
2001 *------------------------------------------------*/
2002
2003 int C2F(getpoly)(char *fname,int *topk,int *lw,int *it,int *m,int *n,char *namex,int *namel,int *ilp,int *lr,int *lc,unsigned long fname_len,unsigned long name_len)
2004 {
2005   int ix1;
2006
2007   int il;
2008   il = iadr(*Lstk(*lw ));
2009   if (*istk(il ) != 2) {
2010     Scierror(212,_("%s: Wrong type for argument %d: Polynomial matrix expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
2011     return FALSE;
2012   } ;
2013   *m = *istk(il +1);
2014   *n = *istk(il +2);
2015   *it = *istk(il + 3);
2016   *namel = 4;
2017   C2F(cvstr)(namel, istk(il + 4), namex, &cx1, 4L);
2018  L11:
2019   if (*namel > 0) {
2020     if ( namex[*namel - 1] == ' ') {
2021       --(*namel);
2022       goto L11;
2023     }
2024   }
2025   *ilp = il + 8;
2026   ix1 = *ilp + *m * *n + 1;
2027   *lr = sadr(ix1) - 1;
2028   *lc = *lr + *istk(*ilp + *m * *n ) - 1;
2029   return  TRUE;
2030
2031
2032
2033
2034 /*------------------------------------------------------------------ 
2035 *     recupere un polynome 
2036 *     md est son degre et son premier element est en 
2037 *     stk(lr),stk(lc) 
2038 *     Finir les tests 
2039 *------------------------------------------------------------------ */
2040
2041 int C2F(getonepoly)(char *fname,int *topk,int *lw,int *it,int *md,char *namex,int *namel,int *lr,int *lc, unsigned long fname_len, unsigned long name_len)
2042 {
2043   int m, n;
2044   int ilp;
2045
2046   if (C2F(getpoly)(fname, topk, lw, it, &m, &n, namex, namel, &ilp, lr, lc, fname_len, 4L)
2047       == FALSE)
2048     return FALSE;
2049
2050   if (m * n != 1) {
2051     Scierror(998,_("%s: Wrong type for argument %d : Polygon expected.\n"),get_fname(fname,fname_len),Rhs + (*lw - *topk));
2052     return FALSE;
2053   }
2054   *md = *istk(ilp +1) - *istk(ilp ) - 1;
2055   *lr += *istk(ilp );
2056   *lc += *istk(ilp );
2057   return TRUE;
2058
2059
2060 /*------------------------------------------------------------------ 
2061  * pmatj : 
2062  *   checks that there's a polynomial matrix  at position  lw-1 
2063  *   checks that the j-th column  can be extracted at lw position 
2064  *   perform the extraction 
2065  *       lw : position 
2066  *       j  : column  to be extracted 
2067  *------------------------------------------------------------------ */
2068
2069 int C2F(pmatj)(char *fname,int *lw,int *j,unsigned long fname_len)
2070 {
2071   int ix1, ix2;
2072   char namex[4];
2073   int incj;
2074   int ix, l, m, n, namel;
2075   int l2, m2, n2, lc, il, lj, it, lr, il2, ilp;
2076
2077   if (*lw + 1 >= Bot) {
2078     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
2079     return FALSE;
2080   }
2081   ix1 = *lw - 1;
2082   ix2 = *lw - 1;
2083   if (! C2F(getpoly)(fname, &ix1, &ix2, &it, &m, &n, namex, &namel, &ilp, &lr, &lc, fname_len, 4L)) {
2084     return FALSE;
2085   }
2086   if (*j > n)     return FALSE;
2087
2088   /*     a ameliorer */
2089   il = iadr(*Lstk(*lw - 2 +1));
2090   incj = (*j - 1) * m;
2091   il2 = iadr(*Lstk(*lw ));
2092   ix1 = il2 + 4;
2093   l2 = sadr(ix1);
2094   m2 = Max(m,1);
2095   ix1 = il + 9 + m * n;
2096   l = sadr(ix1);
2097   n = *istk(il + 8 + m * n );
2098   ix1 = il2 + 9 + m2;
2099   l2 = sadr(ix1);
2100   n2 = *istk(il + 8 + incj + m ) - *istk(il + 8 + incj );
2101   Err = l2 + n2 * (it + 1) - *Lstk(Bot );
2102   if (Err > 0) {
2103     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
2104     return FALSE;
2105   }
2106   C2F(icopy)(&cx4, istk(il + 3 +1), &cx1, istk(il2 + 3 +1), &cx1);
2107   il2 += 8;
2108   il = il + 8 + incj;
2109   lj = l - 1 + *istk(il );
2110   *istk(il2 ) = 1;
2111   ix1 = m2;
2112   for (ix = 1; ix <= ix1; ++ix) {
2113     *istk(il2 + ix ) = *istk(il2 - 1 + ix ) + *istk(il + ix ) - *istk(il - 1 + ix );
2114   }
2115   C2F(dcopy)(&n2, stk(lj ), &cx1, stk(l2 ), &cx1);
2116   if (it == 1) {
2117     C2F(dcopy)(&n2, stk(lj + n ), &cx1, stk(l2 + n2 ), &cx1);
2118   }
2119   *Lstk(Top +1) = l2 + n2 * (it + 1);
2120   il2 += -8;
2121   *istk(il2 ) = 2;
2122   *istk(il2 +1) = m2;
2123   *istk(il2 + 1 +1) = 1;
2124   *istk(il2 + 2 +1) = it;
2125   return TRUE;
2126 }
2127
2128 /**********************************************************************
2129  * WORKING ARRAYS 
2130  **********************************************************************/
2131
2132 /*------------------------------------------------------------------ 
2133  * crewmat : uses the rest of the stack as a working area (double)
2134  *    In : 
2135  *       lw : position (entier) 
2136  *    Out: 
2137  *       m  : size that can be used 
2138  *       lr : stk(lr+i) is the working area 
2139  *------------------------------------------------------------------ */
2140
2141 int C2F(crewmat)(char *fname,int *lw,int *m,int *lr,unsigned long fname_len)
2142 {
2143   int il,ix1; 
2144   if (*lw + 1 >= Bot) {
2145     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
2146     return FALSE;
2147   }
2148   il = iadr(*Lstk(*lw ));
2149   *m = *Lstk(Bot ) - sadr(il+4);
2150   *istk(il ) = 1;
2151   *istk(il + 1) = 1;
2152   *istk(il + 2) = *m;
2153   *istk(il + 3) = 0;
2154   ix1 = il + 4;
2155   *lr = sadr(il+4);
2156   *Lstk(*lw +1) = sadr(il+4) + *m;
2157   return TRUE;
2158 }
2159
2160 /*------------------------------------------------------------------ 
2161  * crewimat : uses the rest of the stack as a working area (int)
2162  *    In : 
2163  *       lw : position (entier) 
2164  *    Out: 
2165  *       m  : size that can be used 
2166  *       lr : istk(lr+i) is the working area 
2167  *------------------------------------------------------------------ */
2168
2169 int C2F(crewimat)(char *fname,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
2170 {
2171   double size = ((double) *m) * ((double) *n ); 
2172   int ix1,il;
2173   if (*lw + 1 >= Bot) {
2174     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
2175     return FALSE;
2176   }
2177   il = iadr(*Lstk(*lw ));
2178   Err = il + 3  - iadr(*Lstk(Bot ));
2179   if (Err > -size ) {
2180     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
2181     return FALSE;
2182   }
2183   *istk(il ) = 4;
2184   *istk(il + 1) = *m;
2185   *istk(il + 2) = *n;
2186   *lr = il + 3;
2187   ix1 = il + 3 + *m * *n + 2;
2188   *Lstk(*lw +1) = sadr(ix1);
2189   return TRUE;
2190 }
2191
2192 /*------------------------------------------------
2193  * getwimat : used to get information about 
2194  *     a working area set by crewimat 
2195  *     In : 
2196  *       fname, topk, lw 
2197  *     Out : 
2198  *       m, n :  dimensions 
2199  *       lr : working area is istk(lr+i) i=0,m*n-1
2200  *------------------------------------------------ */
2201
2202 int C2F(getwimat)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
2203 {
2204   int il;
2205   il = iadr(*Lstk(*lw ));
2206   if (*istk(il ) < 0) {
2207     il = iadr(*istk(il +1));
2208   }
2209   if (*istk(il ) != sci_boolean) {
2210     Scierror(213,_("%s: Wrong type for argument %d: Working int matrix expected.\n"),get_fname(fname,fname_len),Rhs + (*lw - *topk));
2211     return FALSE;
2212   };
2213   *m = *istk(il + 1);
2214   *n = *istk(il + 2);
2215   *lr = il + 3;
2216   return TRUE;
2217
2218
2219 /*------------------------------------------------------------------ 
2220  *     creation of an object of type pointer at spos position on the stack 
2221  *     the pointer points to an object of type char matrix created by 
2222  *     the c routine stringc and is filled with a scilab stringmat 
2223  *     which was stored at istk(ilorig) 
2224  *     stk(lw) is used to transmit the pointer 
2225  *     F: transforme une stringmat scilab en un objet de type 
2226  *     pointeur qui pointe vers une traduction en C de la stringMat 
2227  *------------------------------------------------------------------- */
2228
2229 int C2F(crestringv)(char *fname,int *spos,int *ilorig,int *lw,unsigned long fname_len)
2230 {
2231   int ierr;
2232   if (C2F(crepointer)(fname, spos, lw, fname_len) == FALSE) 
2233     return FALSE;
2234
2235   C2F(stringc)(istk(*ilorig ), (char ***)stk(*lw ), &ierr);
2236
2237   if (ierr != 0) {
2238     Scierror(999,_("%s: No more memory.\n"), fname);
2239     return FALSE;
2240   }
2241   return TRUE;
2242 }
2243
2244 /*---------------------------------------------------------- 
2245  *  listcrepointer(top,numero,lw,....) 
2246  *---------------------------------------------------------- */
2247
2248 int C2F(listcrepointer)(char *fname,int *lw,int *numi,int *stlw,int *lrs,unsigned long fname_len)
2249 {
2250   int ix1,il ;
2251   if (C2F(crepointeri)(fname, stlw,  lrs, &c_true, fname_len)==FALSE)
2252     return FALSE ;
2253   *stlw = *lrs + 2;
2254   il = iadr(*Lstk(*lw ));
2255   ix1 = il + *istk(il +1) + 3;
2256   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
2257   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
2258   return TRUE;
2259
2260
2261 /*---------------------------------------------------------- 
2262  *  crepointer :
2263  *---------------------------------------------------------- */
2264
2265 int C2F(crepointer)(char *fname,int *lw,int *lr,unsigned long fname_len)
2266 {
2267
2268   if (*lw + 1 >= Bot) {
2269     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
2270     return FALSE;
2271   }
2272   if ( C2F(crepointeri)(fname, Lstk(*lw ), lr, &c_true, fname_len) == FALSE)
2273     return FALSE ;
2274   *Lstk(*lw +1) = *lr + 2;
2275   return TRUE;
2276
2277
2278 /*--------------------------------------------------------- 
2279  * internal function used by crepointer and listcrepointer 
2280  *---------------------------------------------------------- */
2281 static int C2F(crepointeri)(char *fname,int *stlw,int *lr,int *flagx,unsigned long fname_len)
2282 {
2283   int ix1;
2284   int il;
2285   il = iadr(*stlw);
2286   ix1 = il + 4;
2287   Err = sadr(ix1) + 2 - *Lstk(Bot );
2288   if (Err > 0) {
2289     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
2290     return FALSE;
2291   };
2292   if (*flagx) {
2293     *istk(il ) = sci_lufact_pointer;
2294     /* if m*n=0 then both dimensions are to be set to zero */
2295     *istk(il + 1) = 1;
2296     *istk(il + 2) = 1;
2297     *istk(il + 3) = 0;
2298   }
2299   ix1 = il + 4;
2300   *lr = sadr(ix1);
2301   return TRUE;
2302
2303
2304 /*------------------------------------------------------------------- 
2305  *     creates a Scilab stringpointer on the stack at position spos 
2306  *     of size mxn the stringpointer is filled with the datas stored 
2307  *     in stk(lorig) ( for example created with cstringv ) 
2308  *     and the data stored at stk(lorig) is freed 
2309  *------------------------------------------------------------------- */
2310
2311 int C2F(lcrestringmatfromc)(char *fname,int *spos,int *numi,int *stlw,int *lorig,int *m,int *n,unsigned long fname_len)
2312 {
2313   int ix1;
2314   int ierr;
2315   int il, ilw;
2316   ilw = iadr(*stlw);
2317   ix1 = *Lstk(Bot ) - *stlw;
2318   C2F(cstringf)((char ***)stk(*lorig ), istk(ilw ), m, n, &ix1, &ierr);
2319   if (ierr > 0) {
2320     Scierror(999,_("%s: No more memory.\n"), fname);
2321     return FALSE;
2322   }
2323   ix1 = ilw + 5 + *m * *n + *istk(ilw + 4 + *m * *n ) - 1;
2324   *stlw = sadr(ix1);
2325   il = iadr(*Lstk(*spos ));
2326   ix1 = il + *istk(il +1) + 3;
2327   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
2328   if (*numi == *istk(il +1)) {
2329     *Lstk(*spos +1) = *stlw;
2330   }
2331   return TRUE;
2332 }
2333
2334
2335 /*------------------------------------------------------------------- 
2336  *     creates a Scilab stringmat on the stack at position spos 
2337  *     of size mxn the stringmat is filled with the datas stored 
2338  *     in stk(lorig) ( for example created with cstringv ) 
2339  *     and the data stored at stk(lorig) is freed 
2340  *------------------------------------------------------------------- */
2341
2342 int C2F(crestringmatfromc)(char *fname,int *spos,int *lorig,int *m,int *n,unsigned long fname_len)
2343 {
2344   int ix1;
2345   int ierr;
2346   int ilw;
2347   ilw = iadr(*Lstk(*spos ));
2348   ix1 = *Lstk(Bot ) - *Lstk(*spos );
2349   C2F(cstringf)((char ***)stk(*lorig ), istk(ilw ), m, n, &ix1, &ierr);
2350   if (ierr > 0) {
2351     Scierror(999,_("%s: No more memory.\n"), fname);
2352     return FALSE;
2353   }
2354   ix1 = ilw + 5 + *m * *n + *istk(ilw + 4 + *m * *n ) - 1;
2355   *Lstk(*spos +1) = sadr(ix1);
2356   return  TRUE;
2357 }
2358
2359 /*------------------------------------------------------------------ 
2360  *     getlistvectrow : recupere un vecteur ligne dans une liste 
2361  *------------------------------------------------------------------ */
2362
2363 int C2F(getlistvectrow)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
2364 {
2365   int nv;
2366   int ili;
2367
2368   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE) 
2369     return FALSE;
2370
2371   if (*lnum > nv) {
2372     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
2373     return FALSE;
2374   }
2375
2376   if (C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len)== 
2377       FALSE) 
2378     return FALSE;
2379   if (*m != 1) {
2380     Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Row vector expected.\n"),get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum);
2381     return FALSE;
2382   }
2383   return TRUE;
2384
2385
2386
2387 /*------------------------------------------------------------------ 
2388  *     Fonction normalement identique a getmat mais rajoutee 
2389  *     pour ne pas avoir a changer le stack.f de interf 
2390  *     renvoit .true. si l'argument en spos est une matrice 
2391  *             sinon appelle error et renvoit .false. 
2392  *     Entree : 
2393  *       fname : nom de la routine appellante pour le message 
2394  *       d'erreur 
2395  *       spos    : position ds la pile 
2396  *     Sortie 
2397  *       [it,m,n] caracteristiques de la matrice 
2398  *       lr : pointe sur la partie reelle ( si la matrice est a 
2399  *              a(1,1)=stk(lr) 
2400  *            si l'on veut acceder a des entiers 
2401  *                         a(1,1)=istk(adr(lr,0)) 
2402  *       lc : pointe sur la partie imaginaire si elle existe sinon sur zero 
2403  *------------------------------------------------------------------ */
2404
2405 int C2F(getvectrow)(char *fname,int *topk,int *spos,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
2406 {
2407   if (C2F(getmati)(fname, topk, spos, Lstk(*spos ), it, m, n, lr, lc, &c_false, &cx0, fname_len) == FALSE) 
2408     return FALSE;
2409
2410   if (*m != 1) {
2411     Scierror(999,_("%s: Wrong type for argument %d: Row vector expected.\n"),get_fname(fname,fname_len),Rhs + (*spos - *topk));
2412     return FALSE;
2413   }
2414   return TRUE ;
2415
2416
2417 /*------------------------------------------------------------------ 
2418  *
2419  *------------------------------------------------------------------ */
2420
2421 int C2F(getlistvectcol)(char *fname,int *topk,int *spos,int *lnum,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
2422 {
2423   int nv;
2424   int ili;
2425   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE) 
2426     return FALSE;
2427
2428   if (*lnum > nv) {
2429     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
2430     return FALSE;
2431   }
2432   if ( C2F(getmati)(fname, topk, spos, &ili, it, m, n, lr, lc, &c_true, lnum, fname_len)
2433        == FALSE)
2434     return FALSE;
2435
2436   if (*n != 1) {
2437     Scierror(999,_("%s: argument %d >(%d) should be a column vector.\n"), get_fname(fname,fname_len),Rhs + (*spos - *topk), *lnum);
2438     return FALSE;
2439   }
2440   return TRUE;
2441 }
2442
2443 /*------------------------------------------------------------------ 
2444 *     Fonction normalement identique a getmat mais rajoutee 
2445 *     pour ne pas avoir a changer le stack.f de interf 
2446 *     renvoit .true. si l'argument en spos est une matrice 
2447 *             sinon appelle error et renvoit .false. 
2448 *     Entree : 
2449 *       fname : nom de la routine appellante pour le message 
2450 *       d'erreur 
2451 *       spos    : position ds la pile 
2452 *     Sortie 
2453 *       [it,m,n] caracteristiques de la matrice 
2454 *       lr : pointe sur la partie reelle ( si la matrice est a 
2455 *              a(1,1)=stk(lr) 
2456 *            si l'on veut acceder a des entiers 
2457 *                          a(1,1)=istk(adr(lr,0)) 
2458 *       lc : pointe sur la partie imaginaire si elle existe sinon sur zero 
2459 *------------------------------------------------------------------ */
2460
2461 int C2F(getvectcol)(char *fname,int *topk,int *spos,int *it,int *m,int *n,int *lr,int *lc,unsigned long fname_len)
2462 {
2463
2464   if ( C2F(getmati)(fname, topk, spos, Lstk(*spos ), it, m, n, lr, lc, &c_false, &cx0, fname_len)
2465        == FALSE ) 
2466     return FALSE;
2467
2468   if (*n != 1) {
2469     Scierror(999,_("%s: Wrong type for argument %d: Column vector expected.\n"),get_fname(fname,fname_len),Rhs + (*spos - *topk));
2470     return FALSE;
2471   }
2472   return TRUE;
2473 }
2474
2475
2476 int C2F(getlistsimat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *ix,int *j,int *lr,int *nlr,unsigned long fname_len)
2477 {
2478   int nv;
2479   int ili;
2480
2481   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE) 
2482     return FALSE;
2483
2484   if (*lnum > nv) {
2485     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
2486     return FALSE;
2487   }
2488   return  C2F(getsmati)(fname, topk, spos, &ili, m, n, ix, j, lr, nlr, &c_true, lnum, fname_len);
2489
2490
2491 /*------------------------------------------------------------------- 
2492  *     recuperation d'un pointer 
2493  *------------------------------------------------------------------- */
2494
2495 int C2F(getpointer)(char *fname,int *topk,int *lw,int *lr,unsigned long fname_len)
2496 {
2497   return C2F(getpointeri)(fname, topk, lw,Lstk(*lw), lr, &c_false, &cx0, fname_len);
2498
2499
2500 /*------------------------------------------------------------------ 
2501  * getlistpointer : 
2502  *    checks that spos object is a list 
2503  *    checks that lnum-element of the list exists and is a pointer 
2504  *    extracts pointer value 
2505  *     In  : 
2506  *       fname : name of calling function for error message 
2507  *       topk  : stack ref for error message 
2508  *       spos    : stack position 
2509  *     Out : 
2510  *       lw : stk(lw) a <<pointer>> casted to a double 
2511  *------------------------------------------------------------------ */
2512
2513 int C2F(getlistpointer)(char *fname,int *topk,int *spos,int *lnum,int *lw,unsigned long fname_len)
2514 {
2515   int nv, ili;
2516
2517   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
2518     return FALSE;
2519
2520   if (*lnum > nv) {
2521     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
2522     return FALSE;
2523   }
2524   return C2F(getpointeri)(fname, topk, spos, &ili, lw, &c_true, lnum, fname_len);
2525
2526
2527 /*------------------------------------------------------------------- 
2528  * For internal use 
2529  *------------------------------------------------------------------- */
2530
2531 static int C2F(getpointeri)(char *fname,int *topk,int *spos,int *lw,int *lr,int *inlistx,int *nel,unsigned long fname_len)
2532 {
2533   int il;
2534   il = iadr(*lw);
2535   if (*istk(il ) < 0) il = iadr(*istk(il +1));
2536   if (*istk(il ) != sci_lufact_pointer) {
2537     sciprint("----%d\n",*istk(il));
2538     if (*inlistx) 
2539       Scierror(197,_("%s: Wrong type for argument %d (List element: %d): Boxed pointer expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
2540     else 
2541       Scierror(198,_("%s: Wrong type for argument %d: Boxed pointer expected.\n"),get_fname(fname,fname_len),
2542                Rhs + (*spos - *topk));
2543     return  FALSE;
2544   }
2545   *lr = sadr(il+4);
2546   return TRUE;
2547
2548
2549 /*-----------------------------------------------------------
2550  *     creates a matlab-like sparse matrix 
2551  *-----------------------------------------------------------*/
2552
2553 int C2F(mspcreate)(int *lw,int *m,int *n,int *nzMax,int *it)
2554 {
2555   int ix1;
2556   int jc, il, ir; int NZMAX;
2557   int k,pr;
2558   double size;
2559   if (*lw + 1 >= Bot) {
2560     Scierror(18,_("%s: Too many names.\n"),"");
2561     return FALSE;
2562   }
2563
2564   il = iadr(*Lstk(*lw ));
2565   NZMAX=*nzMax;
2566   if (NZMAX==0) NZMAX=1;
2567   ix1 = il + 4 + (*n + 1) + NZMAX;
2568   size = (*it + 1) * NZMAX ;
2569   Err = sadr(ix1)  - *Lstk(Bot );
2570   if (Err > -size ) {
2571     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),"");
2572     return FALSE;
2573   };
2574   *istk(il ) = sci_matlab_sparse;
2575   /*        si m*n=0 les deux dimensions sont mises a zero. 
2576   *istk(il +1) = Min(*m , *m * *n);
2577   *istk(il + 1 +1) = Min(*n, *m * *n);     */
2578   *istk(il +1) = *m;
2579   *istk(il + 2) = *n;
2580   *istk(il + 3) = *it;
2581   *istk(il + 4) = NZMAX;
2582   jc = il + 5;
2583
2584   for (k=0; k<*n+1; ++k) *istk(jc+k)=0;  /* Jc =0 */
2585   ir = jc + *n + 1;
2586   for (k=0; k<NZMAX; ++k) *istk(ir+k)=0;   /* Ir = 0 */
2587   pr = sadr(ir + NZMAX );
2588
2589   for (k=0; k<NZMAX; ++k) *stk(pr+k)=0;    /* Pr =0  */
2590   ix1 = il + 4 + (*n + 1) + NZMAX;
2591   *Lstk(*lw +1) = sadr(ix1) + (*it + 1) * NZMAX + 1;
2592
2593   C2F(intersci).ntypes[*lw-Top+Rhs-1] = '$';
2594   C2F(intersci).iwhere[*lw-Top+Rhs-1] = *Lstk(*lw);
2595   /* C2F(intersci).lad[*lw-Top+Rhs-1] = should point to numeric data */
2596   return TRUE;
2597 }
2598
2599 /**********************************************************************
2600  * Utilities 
2601  **********************************************************************/
2602
2603 /*------------------------------------------
2604  * get_fname used for function names which can be non   
2605  * null-terminated strings when coming from 
2606  * a Fortran call
2607  *------------------------------------------*/
2608
2609 static char Fname[nlgh+1];
2610
2611 char *get_fname(char *fname,unsigned long fname_len)
2612 {
2613   int i=0;
2614   int minlength = Min(fname_len,nlgh);
2615   strncpy(Fname,fname,minlength);
2616   Fname[minlength] = '\0';
2617   for ( i= 0 ; i < (int) minlength ; i++) 
2618     if (Fname[i] == ' ') { Fname[i]= '\0'; break;}
2619   return Fname;
2620 }
2621
2622 /*------------------------------------------------------------------ 
2623  * realmat : 
2624  *     Top is supposed to be a matrix 
2625  *     and the matrix is chnaged to its real part 
2626  *------------------------------------------------------------------ */
2627
2628 int C2F(realmat)(void)
2629 {
2630   int ix1;
2631   int m, n, il;
2632
2633   il = iadr(*Lstk(Top ));
2634   if (*istk(il + 3 ) == 0) return 0;
2635   m = *istk(il + 1);
2636   n = *istk(il + 2);
2637   *istk(il + 3) = 0;
2638   ix1 = il + 4;
2639   *Lstk(Top +1) = sadr(ix1) + m * n;
2640   return 0;
2641 }
2642
2643
2644
2645
2646 /*------------------------------------------------------------------ 
2647 *     copie l'objet qui est a la position lw de la pile 
2648 *     a la position lwd de la pile 
2649 *     copie faite avec dcopy 
2650 *     pas de verification 
2651 *      implicit undefined (a-z) 
2652 *------------------------------------------------------------------ */
2653
2654 int C2F(copyobj)(char *fname,int *lw,int *lwd,unsigned long fname_len)
2655 {
2656   int ix1,l,ld;
2657   l=*Lstk(*lw );
2658   ld=*Lstk(*lwd );
2659
2660   ix1 = *Lstk(*lw +1) - l;
2661   /* check for overlaping region */
2662   if (l+ix1>ld||ld+ix1>l) 
2663     C2F(unsfdcopy)(&ix1, stk(l), &cx1, stk(ld), &cx1);
2664   else
2665     C2F(scidcopy)(&ix1, stk(l), &cx1, stk(ld), &cx1);
2666   *Lstk(*lwd +1) = ld + ix1;
2667   return 0;
2668 }
2669
2670
2671
2672 /*------------------------------------------------
2673  *     copie l'objet qui est a la position lw de la pile
2674  *     a la position lwd de la pile 
2675  *     copie faite avec dcopy 
2676  *     et verification 
2677  *------------------------------------------------*/
2678
2679 int C2F(vcopyobj)(char *fname,int *lw,int *lwd,unsigned long fname_len)
2680 {
2681   int l;
2682   int l1, lv;
2683   l = *Lstk(*lw );
2684   lv = *Lstk(*lw +1) - *Lstk(*lw );
2685   l1 = *Lstk(*lwd );
2686   if (*lwd + 1 >= Bot) {
2687     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
2688     return FALSE;
2689   }
2690   Err = *Lstk(*lwd ) + lv - *Lstk(Bot );
2691   if (Err > 0) {
2692     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
2693     return FALSE;
2694   }
2695   /* check for overlaping region */
2696   if (l+lv>l1||l1+lv>l) 
2697     C2F(unsfdcopy)(&lv, stk(l), &cx1, stk(l1), &cx1);
2698   else
2699     C2F(scidcopy)(&lv, stk(l), &cx1, stk(l1), &cx1);
2700
2701   *Lstk(*lwd +1) = *Lstk(*lwd ) + lv;
2702   return TRUE;
2703
2704
2705
2706
2707 /*------------------------------------------------== 
2708 *     suppose qu'il y a une matrice en lw de taille it1,m1,n1,mn1, 
2709 *     et une autre en lw+1 de taille it2,m2,n2,mn2 
2710 *     et echange les matrices et change les valeurs de it1,m1,n1,... 
2711 *     apres echange la taille de la matrice en lw est stocke ds(it1,m1,n1) 
2712 *     et celle en lw+1 est stocke ds (it2,m2,n2) 
2713 *     effet de bord il faut que lw+2 soit une place libre 
2714 *------------------------------------------------== */
2715
2716
2717 int C2F(swapmat)(char *fname,int *topk,int *lw,int *it1,int *m1,int *n1,int *mn1,int *it2,int *m2,int *n2,int *mn2,unsigned long fname_len)
2718 {
2719   int ix1, ix2;
2720   int lc, lr;
2721   ix1 = *lw + 1;
2722
2723   if ( C2F(cremat)(fname, &ix1, it1, m1, n1, &lr, &lc, fname_len)== FALSE)
2724     return FALSE ;
2725
2726   ix1 = *lw + 2;
2727   C2F(copyobj)(fname, lw, &ix1, fname_len);
2728   ix1 = *lw + 1;
2729   C2F(copyobj)(fname, &ix1, lw, fname_len);
2730   ix1 = *lw + 2;
2731   ix2 = *lw + 1;
2732   C2F(copyobj)(fname, &ix1, &ix2, fname_len);
2733   if ( C2F(getmat)(fname, topk, lw, it1, m1, n1, &lr, &lc, fname_len) == FALSE )
2734     return FALSE;
2735
2736   ix1 = *lw + 1;
2737
2738   if (C2F(getmat)(fname, topk, &ix1, it2, m2, n2, &lr, &lc, fname_len) == FALSE )
2739     return FALSE;
2740
2741   *mn1 = *m1 * *n1;
2742   *mn2 = *m2 * *n2;
2743
2744   return TRUE;
2745
2746
2747
2748 /*------------------------------------------------== 
2749 *     verifie qu'en lw il y a une matrice de taille (it1,m1,n1) 
2750 *     deplace cette matrice en lw+1, en reservant en lw 
2751 *     la place pour stocker une matrice (it,m,n) 
2752 *     insmat  verifie  qu'on a la place de faire tout ca 
2753 *     appelle error en cas de probleme 
2754 *     Remarque : noter par exemple que si it=it1,m1=m,n1=n 
2755 *        alors apres le contenu de la matrice en lw est une copie de 
2756 *        celle en lw+1 
2757 *     Remarque : lw doit etre top car sinon on perd ce qu'il y avait avant 
2758 *        en lw+1,....,lw+n 
2759 *     Entree : 
2760 *        lw : position 
2761 *        it ,m,n : taille de la matrice a inserer 
2762 *     Sortie : 
2763 *       lr : pointe sur la partie reelle de la matrice 
2764 *            en lw (   a(1,1)=stk(lr)) 
2765 *       lc : pointe sur la partie imaginaire si besoin est 
2766 *       lr1,lc1 : meme signification mais pour la matrice en lw+1 
2767 *            ( matrice qui a ete copiee de lw a lw+1 
2768 *------------------------------------------------== */
2769
2770 int C2F(insmat)(int *topk,int *lw,int *it,int *m,int *n,int *lr,int *lc,int *lr1,int *lc1)
2771 {
2772
2773   int ix1;
2774   int c_n1 = -1;
2775   int m1, n1;
2776   int lc0, it1, lr0;
2777   
2778   if (C2F(getmat)("insmat", topk, lw, &it1, &m1, &n1, &lr0, &lc0, 6L) == FALSE) 
2779     return FALSE;
2780
2781   if (C2F(cremat)("insmat", lw, it, m, n, lr, lc, 6L)  == FALSE) 
2782     return FALSE;
2783
2784   ix1 = *lw + 1;
2785
2786   if (C2F(cremat)("insmat", &ix1, &it1, &m1, &n1, lr1, lc1, 6L) == FALSE) 
2787     return FALSE;
2788
2789   ix1 = m1 * n1 * (it1 + 1);
2790   C2F(dcopy)(&ix1, stk(lr0 ), &c_n1, stk(*lr1 ), &c_n1);
2791   return TRUE;
2792
2793
2794
2795
2796
2797 /*------------------------------------------------
2798  *     imprime le contenu de la pile en lw en mode entier ou 
2799  *        double precision suivant typ 
2800  *------------------------------------------------*/
2801
2802 int C2F(stackinfo)(int *lw,int *typ)
2803 {
2804   int ix, l, m, n;
2805   int il, nn;
2806
2807   if (*lw == 0) {
2808     return 0;
2809   }
2810   il = iadr(*Lstk(*lw ));
2811   if (*istk(il ) < 0) {
2812     il = iadr(*istk(il +1));
2813   }
2814   m = *istk(il +1);
2815   n = *istk(il + 1 +1);
2816
2817   sciprint("-----------------stack-info-----------------\n");
2818   sciprint("lw=%d -[istk]-> il lw+1 -[istk]-> %d\n",*lw,iadr(*Lstk(*lw+1)));
2819   sciprint("istk(%d:..) ->[%d %d %d %d ....]\n",il, istk(il),istk(il+1),istk(il+2),istk(il+3) );
2820   if (*typ == 1) {
2821     l = sadr(il+4);
2822     nn = Min(m*n,3);
2823     for (ix = 0; ix <= nn-1 ; ++ix) {
2824       sciprint("%5.2f  ",stk(l + ix ));
2825     }
2826   } else {
2827     l = il + 4;
2828     nn = Min(m*n,3);
2829     for (ix = 0; ix <= nn-1; ++ix) {
2830       sciprint("%5d  ",istk(l + ix ));
2831     }
2832   }
2833   sciprint("\n");
2834   sciprint("-----------------stack-info-----------------\n");
2835   return 0;
2836 }
2837
2838
2839
2840 /*------------------------------------------------
2841  * allmat :
2842  *  checks if object at position lw is a matrix 
2843  *  (scalar,string,polynom) 
2844  *  In : 
2845  *     fname,topk,lw 
2846  *  Out : 
2847  *     m,n
2848  *------------------------------------------------*/
2849
2850 int C2F(allmat)(char *fname,int *topk,int *lw,int *m,int *n,unsigned long fname_len)
2851 {
2852   int itype, il;
2853   il = iadr(*Lstk(*lw ));
2854   if (*istk(il ) < 0) il = iadr(*istk(il +1));
2855   itype = *istk(il );
2856   if (itype != sci_matrix && itype != sci_poly && itype != sci_strings) {
2857     Scierror(209,_("%s: Wrong type for argument %d: Matrix expected.\n"),get_fname(fname,fname_len) ,  Rhs + (*lw - *topk));
2858     return FALSE;
2859   }
2860   *m = *istk(il + 1);
2861   *n = *istk(il + 2);
2862   return TRUE;
2863
2864
2865 /*------------------------------------------------
2866  * Assume that object at position lw is a matrix 
2867  * and set its size to (m,n) 
2868  *------------------------------------------------*/
2869
2870 int C2F(allmatset)(char *fname,int *lw,int *m,int *n,unsigned long fname_len)
2871 {
2872   int il;
2873   il = iadr(*Lstk(*lw ));
2874   if (*istk(il ) < 0) il = iadr(*istk(il +1));
2875   *istk(il + 1) = *m;
2876   *istk(il + 2) = *n;
2877   return 0;
2878
2879
2880 /*------------------------------------------------
2881  *     cree un objet vide en lw et met a jour lw+1 
2882  *     en fait lw doit etre top 
2883  *     verifie les cas particuliers lw=0 ou lw=1 
2884  *     ainsi que le cas particulier ou une fonction 
2885  *     n'a pas d'arguments (ou il faut faire top=top+1) 
2886  *------------------------------------------------ */
2887
2888 int C2F(objvide)(char *fname,int *lw,unsigned long fname_len)
2889 {
2890   if (*lw == 0 || Rhs < 0) {
2891     ++(*lw);
2892   }
2893   *istk(iadr(*Lstk(*lw )) ) = 0;
2894   *Lstk(*lw +1) = *Lstk(*lw ) + 2;
2895   return 0;
2896 }
2897
2898 /*------------------------------------------------
2899  *     renvoit .true. si l'argument en lw est un ``external'' 
2900  *             sinon appelle error et renvoit .false. 
2901  *     si l'argument est un external de type string 
2902  *         on met a jour la table des fonctions externes 
2903  *         corespondante en appellant fun 
2904  *     Entree : 
2905  *       fname : nom de la routine appellante pour le message 
2906  *       d'erreur 
2907  *       topk : numero d'argument d'appel pour le message d'ereur 
2908  *       lw    : position ds la pile 
2909  *     Sortie 
2910  *       type vaut true ou false 
2911  *       si l'external est de type chaine de caracteres 
2912  *       la chaine est mise ds name 
2913  *       et type est mise a true 
2914  *------------------------------------------------ */
2915
2916 int C2F(getexternal)(char *fname,int *topk,int *lw,char *namex,int *typex,void (*setfun)(char *,int *),unsigned long fname_len,unsigned long name_len)
2917 {
2918   int ret_value;
2919   int irep;
2920   int m, n;
2921   int il, lr;
2922   int nlr;
2923   int i;
2924   il = C2F(gettype)(lw);
2925   switch ( il) {
2926   case sci_u_function : case sci_c_function : case sci_list :
2927     ret_value = TRUE;
2928     *typex = FALSE;
2929     break;
2930   case sci_strings :
2931     ret_value = C2F(getsmat)(fname, topk, lw, &m, &n, &cx1, &cx1, &lr, &nlr, fname_len);
2932     *typex = TRUE;
2933     for (i=0; i < (int)name_len ; i++ ) namex[i] = ' ';
2934     if (ret_value == TRUE) 
2935       {
2936         C2F(cvstr)(&nlr, istk(lr ), namex, &cx1, name_len);
2937         namex[nlr] = '\0';
2938         (*setfun)(namex, &irep); /* , name_len); */
2939         if (irep == 1) 
2940           {
2941                   Scierror(50,_("%s: entry point %s not found in predefined tables or link table.\n"),get_fname(fname,fname_len),namex);
2942             ret_value = FALSE;
2943           }
2944       }
2945     break;
2946   default: 
2947     Scierror(211,_("%s: Wrong type for argument %d: Function or string (external function) expected.\n"),get_fname(fname,fname_len), Rhs + (*lw - *topk));
2948     ret_value = FALSE;
2949     break;
2950   }
2951   return ret_value;
2952
2953
2954 /*------------------------------------------------
2955  *------------------------------------------------ */
2956
2957 int C2F(checkval)(char *fname,int *ival1,int *ival2,unsigned long fname_len)
2958 {
2959   if (*ival1 != *ival2) 
2960   {
2961     Scierror(999,_("%s: Incompatible sizes.\n"),get_fname(fname,fname_len));
2962     return  FALSE;
2963   } ;
2964   return  TRUE;
2965 }
2966
2967 /*------------------------------------------------------------- 
2968  *      recupere si elle existe la variable name dans le stack et 
2969  *      met sa valeur a la position top et top est incremente 
2970  *      ansi que rhs 
2971  *      si la variable cherchee n'existe pas on renvoit false 
2972  *------------------------------------------------------------- */
2973
2974 int C2F(optvarget)(char *fname,int *topk,int *iel,char *namex,unsigned long fname_len,unsigned long name_len)
2975 {
2976   int id[nsiz];
2977   C2F(cvname)(id, namex, &cx0, name_len);
2978   Fin = 0;
2979   /*     recupere la variable et incremente top */
2980   C2F(stackg)(id);
2981   if (Fin == 0) {
2982     Scierror(999,_("%s: Optional argument %d not given and default value %s not found.\n"),get_fname(fname,fname_len),*iel,namex);
2983     return FALSE;
2984   }
2985   ++Rhs;
2986   return TRUE;
2987 }
2988
2989
2990 /*------------------------------------------------------------- 
2991  * this routine adds nlr characters (coded in istk(*lr)) 
2992  * + a null character in Scilab character buffer C2F(cha1).buf
2993  * the characters are stored at position lbuf 
2994  * lbuf,lbufi,lbuff are the updated : 
2995  *     buf(lbufi:lbuff) will give the characters in buf at Fortran level 
2996  * and lbuf will give the next available position (i.e lbuff+2 since 
2997  * '\0' is added at position lbuff+1 
2998  * 
2999  * Note that at Fortran level buf(lbufi:lbuff) can be used as a C string argument 
3000  * since it is null terminated 
3001  *
3002  *------------------------------------------------------------- */
3003
3004 int C2F(bufstore)(char *fname,int *lbuf,int *lbufi,int *lbuff,int *lr,int *nlr,unsigned long fname_len)
3005 {
3006   *lbufi = *lbuf;
3007   *lbuff = *lbufi + *nlr - 1;
3008   *lbuf = *lbuff + 2;
3009   if (*lbuff > bsiz) {
3010     Scierror(999,_("%f: No more space to store string arguments.\n"),get_fname(fname,fname_len) );
3011     return FALSE;
3012   }
3013   /* lbufi is a Fortran indice ==> offset -1 at C level */
3014   C2F(cvstr)(nlr, istk(*lr ), C2F(cha1).buf + (*lbufi - 1), &cx1, *lbuff - (*lbufi - 1));
3015   C2F(cha1).buf[*lbuff] = '\0';
3016   return TRUE;
3017 }
3018
3019
3020 /*------------------------------------------------------------- 
3021  * 
3022  *------------------------------------------------------------- */
3023 int C2F(credata)(char *fname,int *lw,int m,unsigned long fname_len)
3024 {
3025   int lr;
3026   lr = *Lstk(*lw );
3027   if (*lw + 1 >= Bot) {
3028     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
3029     return FALSE;
3030   }
3031   
3032   Err = lr   - *Lstk(Bot);
3033   if (Err > -m ) {
3034     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
3035     return FALSE;
3036   };
3037   /*  *Lstk(*lw +1) = lr + 1 + m/sizeof(double);  */
3038   /*    type 0  */
3039   *istk(iadr(lr)) = 0;
3040   *Lstk(*lw +1) = lr + (m+sizeof(double)-1)/sizeof(double);
3041   return TRUE;
3042
3043 /* ==============================================================
3044 MATRIX OF HANDLE
3045 ================================================================= */
3046 /*--------------------------------------------------------- 
3047  * internal function used by crehmat and listcrehmat 
3048  *---------------------------------------------------------- */
3049
3050 static int C2F(crehmati)(char *fname,int *stlw,int *m,int *n,int *lr,int *flagx,unsigned long fname_len)
3051 {
3052   int ix1;
3053   int il;
3054   double size = ((double) *m) * ((double) *n);
3055   il = iadr(*stlw);
3056   ix1 = il + 4;
3057   Err = sadr(ix1) - *Lstk(Bot );
3058   if ( (double) Err > -size ) {
3059     Scierror(17,_("%s: stack size exceeded (Use stacksize function to increase it).\n"),get_fname(fname,fname_len));
3060     return FALSE;
3061   };
3062   if (*flagx) {
3063     *istk(il ) = sci_handles;
3064     /* if m*n=0 then both dimensions are to be set to zero */
3065     *istk(il + 1) = Min(*m , *m * *n);
3066     *istk(il + 2) = Min(*n ,*m * *n);
3067     *istk(il + 3) = 0;
3068   }
3069   ix1 = il + 4;
3070   *lr = sadr(ix1);
3071   return TRUE;
3072
3073
3074 /*---------------------------------------------------------- 
3075  *  listcrehmat(top,numero,lw,....) 
3076  *      le numero ieme element de la liste en top doit etre un matrice 
3077  *      stockee a partir de Lstk(lw) 
3078  *      doit mettre a jour les pointeurs de la liste 
3079  *      ainsi que stk(top+1) 
3080  *      si l'element a creer est le dernier 
3081  *      lw est aussi mis a jour 
3082  *---------------------------------------------------------- */
3083
3084 int C2F(listcrehmat)(char *fname,int *lw,int *numi,int *stlw,int *m,int *n,int *lrs,unsigned long fname_len)
3085 {
3086   int ix1,il ;
3087     
3088   if (C2F(crehmati)(fname, stlw, m, n, lrs, &c_true, fname_len)==FALSE)
3089     return FALSE ;
3090
3091   *stlw = *lrs + *m * *n;
3092   il = iadr(*Lstk(*lw ));
3093   ix1 = il + *istk(il +1) + 3;
3094   *istk(il + 2 + *numi ) = *stlw - sadr(ix1) + 1;
3095   if (*numi == *istk(il +1))  *Lstk(*lw +1) = *stlw;
3096   return TRUE;
3097
3098
3099 /*---------------------------------------------------------- 
3100  *  crehmat :
3101  *   checks that a matrix of handle of size [m,n] can be stored at position  lw 
3102  *   <<pointers>> to data is returned on success
3103  *   In : 
3104  *     lw : position (entier) 
3105  *     m, n dimensions 
3106  *   Out : 
3107  *     lr : stk(lr+i-1)= h(i)
3108  *   Side effect : if matrix creation is possible 
3109  *     [m,n] are stored in Scilab stack 
3110  *     and lr is returned but stk(lr+..)  are unchanged 
3111  *---------------------------------------------------------- */
3112
3113 int C2F(crehmat)(char *fname,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
3114 {
3115
3116   if (*lw + 1 >= Bot) {
3117     Scierror(18,_("%s: Too many names.\n"),get_fname(fname,fname_len));
3118     return FALSE;
3119   }
3120   if ( C2F(crehmati)(fname, Lstk(*lw ), m, n, lr, &c_true, fname_len) == FALSE)
3121     return FALSE ;
3122   *Lstk(*lw +1) = *lr + *m * *n;
3123   return TRUE;
3124
3125 /*------------------------------------------------------------------ 
3126  * getlisthmat : 
3127  *    checks that spos object is a list 
3128  *    checks that lnum-element of the list exists and is a matrix 
3129  *    extracts matrix information(m,n,lr) 
3130  *     In  : 
3131  *       fname : name of calling function for error message 
3132  *       topk  : stack ref for error message 
3133  *       lw    : stack position 
3134  *     Out : 
3135  *       [m,n] matrix dimensions 
3136  *       lr : stk(lr+i-1)= h(i)) 
3137  *------------------------------------------------------------------ */
3138
3139 int C2F(getlisthmat)(char *fname,int *topk,int *spos,int *lnum,int *m,int *n,int *lr,unsigned long fname_len)
3140 {
3141   int nv, ili;
3142
3143   if ( C2F(getilist)(fname, topk, spos, &nv, lnum, &ili, fname_len) == FALSE)
3144     return FALSE;
3145
3146   if (*lnum > nv) {
3147     Scierror(999,_("%s: Wrong size for argument %d: At least %d expected.\n"),get_fname(fname,fname_len), Rhs+(*spos - *topk), *lnum);
3148     return FALSE;
3149   }
3150   return C2F(gethmati)(fname, topk, spos, &ili, m, n, lr, &c_true, lnum, fname_len);
3151
3152
3153 /*------------------------------------------------------------------- 
3154  * gethmat :
3155  *     check that object at position lw is a matrix 
3156  *     In  : 
3157  *       fname : name of calling function for error message 
3158  *       topk  : stack ref for error message 
3159  *       lw    : stack position ( ``in the top sense'' )
3160  *     Out : 
3161  *       [m,n] matrix dimensions 
3162  *       lr : stk(lr+i-1)= h(i)
3163  *------------------------------------------------------------------- */
3164
3165 int C2F(gethmat)(char *fname,int *topk,int *lw,int *m,int *n,int *lr,unsigned long fname_len)
3166 {
3167   return C2F(gethmati)(fname, topk, lw,Lstk(*lw), m, n, lr, &c_false, &cx0, fname_len);
3168 }
3169
3170 /*------------------------------------------------------------------- 
3171  * For internal use 
3172  *------------------------------------------------------------------- */
3173
3174 static int C2F(gethmati)(char *fname,int *topk,int *spos,int *lw,int *m,int *n,int *lr,int *inlistx,int *nel,unsigned long fname_len)
3175 {
3176   int il;
3177   il = iadr(*lw);
3178   if (*istk(il ) < 0) il = iadr(*istk(il +1));
3179   if (*istk(il ) != sci_handles) {
3180     if (*inlistx) 
3181       Scierror(999,_("%s: Wrong type for argument %d (List element: %d): Matrix of handle expected.\n"),get_fname(fname,fname_len), Rhs + (*spos - *topk), *nel);
3182     else 
3183       Scierror(200,_("%s: Wrong type for argument %d: Matrix of handle expected.\n"),get_fname(fname,fname_len),
3184                Rhs + (*spos - *topk));
3185     return  FALSE;
3186   }
3187   *m = *istk(il + 1);
3188   *n = *istk(il + 2);
3189   *lr = sadr(il+4);
3190   return TRUE;
3191
3192