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