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