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