88433c55c4aa3497c8538831bda06e8a08a38aa0
[scilab.git] / scilab / modules / core / src / c / stack2.c
1 /*------------------------------------------------------------------------
2  *    Scilab Memory Management library (Stack API)
3  *    Copyright (C) 1998-2000 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  * @authors Bruno JOFRET
11  --------------------------------------------------------------------------*/
12
13 /*---------------------------------------------------------------------
14  * Interface Library:   ilib
15  *---------------------------------------------------------------------*/
16
17 #include <string.h>
18 #include <stdio.h>
19
20 #include "MALLOC.h"
21 #include "machine.h"
22 #include "stack-c.h"
23 #include "sciprint.h"
24 #include "stack2.h"
25 #include "cvstr.h"
26 #include "parse.h"
27 #include "men_Sutils.h"
28 #include "int2db.h"
29 #include "rea2b.h"
30 #include "Scierror.h"
31 #include "localization.h"
32
33 #ifdef _MSC_VER
34 #define abs(x) ((x) >= 0 ? (x) : -(x)) /* pour abs  C2F(mvfromto) line 2689 */
35 #endif
36 /* Table of constant values */
37 static integer cx1 = 1;
38 static integer cx0 = 0;
39
40 static char *Get_Iname __PARAMS((void));
41 static int C2F(mvfromto) __PARAMS((integer *itopl,integer *));
42
43 static int rhs_opt_find __PARAMS((char *name,rhs_opts opts[]));
44 static void rhs_opt_print_names __PARAMS((rhs_opts opts[]));
45
46 /*------------------------------------------------*/
47 void strcpy_tws(char *str1,char *str2, int len);
48 int C2F(copyvarfromsciptr)(integer lw, integer n,integer l);
49 static int intersci_push(void);
50 static void intersci_pop(void);
51
52
53 static void ConvertData(unsigned char *type, int size,int l);
54 /*------------------------------------------------
55  * checkrhs: checks right hand side arguments
56  *-----------------------------------------------*/
57
58 int C2F(checkrhs)(char *fname, integer *iMin, integer *iMax, unsigned long  fname_len)
59 {
60   /*
61    * store the name in recu array, fname can be a non null terminated char array
62    * Get_Iname() can be used in other function to get the interface name
63    */
64
65   C2F(cvname)(&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], fname, &cx0, fname_len);
66
67   if ( Rhs < *iMin || Rhs > *iMax)
68     {
69                 Scierror(77,_("%s : wrong number of input arguments (RHS)\n"),get_fname(fname,fname_len));
70       return FALSE_;
71     }
72   return TRUE_;
73 }
74
75 /*------------------------------------------------
76  * checkrhs: checks left hand side arguments
77  *-----------------------------------------------*/
78
79 int C2F(checklhs)(char *fname, integer *iMin, integer *iMax, unsigned long  fname_len)
80 {
81   if ( Lhs < *iMin || Lhs > *iMax)
82     {
83                 Scierror(78,_("%s : wrong number of output arguments (LHS)\n"),get_fname(fname,fname_len));
84       return FALSE_;
85     }
86   return TRUE_;
87 }
88
89 /*---------------------------------------------------------------------
90  * isopt:
91  * returns the status of the variable number k
92  * if its an optional variable f(x=...)
93  * returns .true. and variable name in namex
94  * namex must have a size of nlgh + 1
95  *---------------------------------------------------------------------*/
96
97 int C2F(isopt)(integer *k, char *namex,unsigned long name_len)
98 {
99   integer i1 =  *k + Top - Rhs;
100   if ( C2F(isoptlw)(&Top, &i1, namex, name_len) == FALSE_) return FALSE_ ;
101   /* add a '\0' at the end of the string removing trailing blanks */
102   for ( i1 = nlgh-1 ; i1 >=0 ; i1--) { if ( namex[i1] != ' ') break ;}
103   namex[i1+1]='\0';
104   return TRUE_;
105 }
106
107 /*---------------------------------------
108  * isoptlw :
109  * returns the status of the variable at position lw in the stack
110  * if its an optional variable f(x=...)
111  * returns .true. and variable name in namex
112  *--------------------------------------- */
113
114 int C2F(isoptlw)(integer *topk,integer  *lw, char *namex, unsigned long name_len)
115 {
116   if (*Infstk(*lw ) != 1) return FALSE_ ;
117   C2F(cvname)(&C2F(vstk).idstk[(*lw) * nsiz - nsiz], namex, &cx1, name_len);
118   return TRUE_;
119 }
120
121 /*---------------------------------------
122  * firstopt :
123  * return the position of the first optionnal argument
124  * given as xx=val in the calling sequence.
125  * If no such argument it returns Rhs+1.
126  *--------------------------------------- */
127 integer C2F(firstopt)()
128
129 {
130   integer k;
131   for (k = 1; k <= Rhs ; ++k)
132     if (*Infstk(k + Top - Rhs )==1)
133       return k;
134   return(Rhs+1);
135 }
136
137
138 /*---------------------------------------
139  * findopt :
140  * checks if option str has been passed.
141  * If yes returns the position of the variable
142  * If no  returns 0
143  *--------------------------------------- */
144
145 int C2F(findopt)(char * str,rhs_opts opts[])
146 {
147   int i, pos;
148
149   pos = 0;
150   i = rhs_opt_find(str,opts);
151   if ( i>=0 )
152     if (opts[i].position>0)
153       pos = opts[i].position;
154
155   return(pos);
156 }
157
158
159 /*---------------------------------------
160  * numopt :
161  *  returns the number of optional variables
162  *  given as xx=val in the caling sequence
163  *  top must have a correct value when using this function
164  *--------------------------------------- */
165
166 integer C2F(numopt)()
167 {
168   integer k, ret=0;
169   for (k = 1; k <= Rhs ; ++k)
170     if ( *Infstk(k + Top - Rhs) == 1 ) ret++;
171   return ret;
172 }
173
174 /*---------------------------------------------------------------------
175  * vartype:
176  *   type of variable number number in the stack
177  *---------------------------------------------------------------------*/
178
179 integer C2F(vartype)(integer *number)
180 {
181   integer ix1=  *number + Top - Rhs;
182   return  C2F(gettype)(&ix1);
183 }
184
185 /*------------------------------------------------
186  * gettype:
187  *    returns the type of object at position lw in the stack
188  *------------------------------------------------*/
189
190 integer C2F(gettype)(integer *lw)
191 {
192   integer il;
193   il = iadr(*Lstk(*lw ));
194   if (*istk(il ) < 0) il = iadr(*istk(il +1));
195   return *istk(il);
196 }
197
198
199 /*------------------------------------------------
200  * overloadtype:
201  *    set mechanism to overloaded function fname if object type
202  *    does not fit given type
203  *------------------------------------------------*/
204
205 static integer overloadtype(integer *lw,char *fname,unsigned char *typ)
206 {
207   integer il=0;
208   integer ityp=0;
209   il = iadr(*Lstk(*lw ));
210   if (*istk(il ) < 0) il = iadr(*istk(il +1));
211   switch (*typ) {
212   case 'c' : /* string */
213   case 'S' : /* string Matrix */
214     ityp=sci_strings;
215     break;
216   case 'd' :  case 'i' :  case 'r' :  case 'z' :   /* numeric */
217     ityp=sci_matrix;
218     break ;
219   case 'b' : /* boolean */
220     ityp=sci_boolean;
221     break;
222   case 'h' : /* handle */
223     ityp=sci_handles;
224     break;
225   case 'l' : /* list */
226     ityp=sci_list;
227     break;
228   case 't' : /* tlist */
229     ityp=sci_tlist;
230     break;
231   case 'm' : /* mlist */
232     ityp=sci_mlist;
233     break;
234   case 'f' : /* external */
235     ityp=sci_c_function;
236     break;
237   case 'p' : /* pointer */
238     ityp=sci_lufact_pointer;
239     break;
240   case 's' : /* sparse */
241     ityp= sci_sparse;
242     break;
243   case 'I' : /* int matrix */
244     ityp=sci_ints;
245     break;
246
247   }
248   if (*istk(il ) != ityp) {
249     return C2F(overload)(lw,fname,(unsigned long)strlen(fname));
250   }
251   return 1;
252 }
253
254
255 /*------------------------------------------------
256  * overload
257  *    set mechanism to overloaded function fname for object lw
258  *------------------------------------------------*/
259
260 integer C2F(overload)(integer *lw,char *fname,unsigned long l)
261 {
262   C2F(putfunnam)(fname,lw,l);
263   C2F(com).fun=-1;
264   return 0;
265 }
266
267
268
269 /*------------------------------------------------
270  * ogettype : unused
271  *------------------------------------------------*/
272 integer C2F(ogettype)(integer *lw)
273 {
274   return  *istk(iadr(*Lstk(*lw )) );
275 }
276
277
278 /*----------------------------------------------------
279  * Optional arguments f(....., arg =val,...)
280  *          in interfaces
281  * function get_optionals : example is provided in
282  *    examples/addinter-examples/intex2c.c
283  *----------------------------------------------------*/
284
285
286 int get_optionals(char *fname ,rhs_opts opts[])
287 {
288   int k,i=0;
289   char name[nlgh+1];
290   int nopt = NumOpt(); /* optional arguments on the stack */
291
292   /* reset first field since opts is declared static in calling function */
293   /* this could be avoided with ansi compilers by removing static in the
294    * opts declaration */
295
296   while ( opts[i].name != NULL )
297     {
298       opts[i].position = -1;
299       i++;
300     }
301
302   /* Walking through last arguments */
303
304   for ( k = Rhs - nopt + 1; k <= Rhs ;k++)
305     {
306       if ( IsOpt(k,name) == 0  )
307         {
308           Scierror(999,_("%s : optional arguments name=val must be at the end.\n"),fname);
309           return 0;
310         }
311       else
312         {
313           int isopt = rhs_opt_find(name,opts);
314           if ( isopt >= 0 )
315             {
316               rhs_opts *ro = &opts[isopt];
317               ro->position = k;
318               if (ro->type[0] != '?')
319                 GetRhsVar(ro->position, ro->type,&ro->m,&ro->n,&ro->l);
320             }
321           else
322             {
323               sciprint(_("%s : unrecognized optional arguments %s.\n"),fname,name);
324               rhs_opt_print_names(opts) ;
325               Error(999);
326               return(0);
327             }
328         }
329     }
330   return 1;
331 }
332
333 /* Is name in opts */
334
335 int rhs_opt_find(char *name,rhs_opts opts[])
336 {
337   int rep=-1,i=0;
338   while ( opts[i].name != NULL )
339     {
340       int cmp;
341       /* name is terminated by white space and we want to ignore them */
342       if ( (cmp=strcmp(name,opts[i].name)) == 0 )
343         {
344           rep = i ; break;
345         }
346       else if ( cmp < 0 )
347         {
348           break;
349         }
350       else
351         {
352           i++;
353         }
354     }
355   return rep;
356 }
357
358 void rhs_opt_print_names(rhs_opts opts[])
359       /* array of optinal names (in alphabetical order)
360                        * the array is null terminated */
361 {
362   int i=0;
363   if ( opts[i].name == NULL )
364     {
365       sciprint(_("optional argument list is empty.\n"));
366       return;
367     }
368   sciprint(_("optional arguments list: \n"));
369   while ( opts[i+1].name != NULL )
370     {
371       sciprint("%s, ",opts[i].name);
372       i++;
373     }
374   sciprint(_("and %s.\n"),opts[i].name);
375   return ;
376 }
377
378 /*---------------------------------------------------------------------
379  * isref :
380  *   checks if variable number lw is on the stack
381  *   or is just a reference to a variable on the stack
382  *---------------------------------------------------------------------*/
383
384 int IsRef(int number) {
385   return C2F(isref)(&number);
386 }
387
388 int C2F(isref)(integer *number)
389 {
390   integer il,lw;
391   lw = *number + Top - Rhs;
392   if ( *number > Rhs) {
393     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),"isref","isref");
394     return FALSE_;
395   }
396   il = iadr(*Lstk(lw));
397   if ( *istk(il) < 0)
398     return TRUE_ ;
399   else
400     return FALSE_ ;
401 }
402
403 /*---------------------------------------------------------------------
404  *     create a variable number lw in the stack of type
405  *     type and size m,n
406  *     the argument must be of type type ('c','d','r','i','l','b')
407  *     return values m,n,lr
408  *     c : string  (m-> number of characters and n->1)
409  *     d,r,i : matrix of double,float or integer
410  *     b : boolean matrix
411  *     l : a list  (m-> number of elements and n->1)
412  *         for each element of the list an other function
413  *         must be used to <<get>> them
414  *     side effects : arguments in the common intersci are modified
415  *     see examples in addinter-examples
416  *---------------------------------------------------------------------*/
417
418 int C2F(createvar)(integer *lw,char *typex,integer *m,integer *n,integer  *lr,unsigned long type_len)
419 {
420   integer ix1, ix, it=0, lw1, lcs, IT;
421   unsigned char Type = *typex;
422   char *fname = Get_Iname();
423   if (*lw > intersiz) {
424     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createvar");
425     return FALSE_ ;
426   }
427   Nbvars = Max(*lw,Nbvars);
428   lw1 = *lw + Top - Rhs;
429   if (*lw < 0) {
430     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createvar");
431     return FALSE_ ;
432   }
433   switch (Type )
434     {
435     case 'c' :
436       ix1 = *m * *n;
437       if (! C2F(cresmat2)(fname, &lw1, &ix1, lr, nlgh)) return FALSE_;
438       *lr = cadr(*lr);
439           // Fill the string with spaces
440       for (ix = 0; ix < (*m)*(*n) ; ++ix) *cstk(*lr+ix)= ' ';
441       *cstk(*lr+ (*m)*(*n) )= '\0';
442       C2F(intersci).ntypes[*lw - 1] = Type;
443       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
444       C2F(intersci).lad[*lw - 1] = *lr;
445       break;
446     case 'd' :
447       if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh))    return FALSE_;
448       C2F(intersci).ntypes[*lw - 1] = Type;
449       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
450       C2F(intersci).lad[*lw - 1] = *lr;
451       break;
452     case 'z' :
453       IT = 1;
454       if (!(*Lstk(lw1) % 2) ) *Lstk(lw1) = *Lstk(lw1)+1;
455       if (! C2F(cremat)(fname, &lw1, &IT, m, n, lr, &lcs, nlgh))    return FALSE_;
456       C2F(intersci).ntypes[*lw - 1] = Type;
457       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
458       C2F(intersci).lad[*lw - 1] = *lr;
459       *lr = sadr(*lr);
460       break;
461     case 'l' :
462       C2F(crelist)(&lw1, m, lr);
463       C2F(intersci).ntypes[*lw - 1] = '$';
464       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
465       C2F(intersci).lad[*lw - 1] = *lr;
466       break;
467     case 't' :
468       C2F(cretlist)(&lw1, m, lr);
469       C2F(intersci).ntypes[*lw - 1] = '$';
470       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
471       C2F(intersci).lad[*lw - 1] = *lr;
472       break;
473     case 'm' :
474       C2F(cremlist)(&lw1, m, lr);
475       C2F(intersci).ntypes[*lw - 1] = '$';
476       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
477       C2F(intersci).lad[*lw - 1] = *lr;
478       break;
479     case 'r' :
480       if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh)) return FALSE_;
481       *lr = iadr(*lr);
482       C2F(intersci).ntypes[*lw - 1] = Type;
483       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
484       C2F(intersci).lad[*lw - 1] = *lr;
485       break ;
486     case 'i' :
487       if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh)) return FALSE_;
488       *lr = iadr(*lr) ;
489       C2F(intersci).ntypes[*lw - 1] = Type;
490       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
491       C2F(intersci).lad[*lw - 1] = *lr;
492       break ;
493     case 'b' :
494       if (! C2F(crebmat)(fname, &lw1, m, n, lr, nlgh))  return FALSE_;
495       C2F(intersci).ntypes[*lw - 1] = Type;
496       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
497       C2F(intersci).lad[*lw - 1] = *lr;
498       break;
499     case 'p' :
500       if (! C2F(crepointer)(fname, &lw1, lr, nlgh))    return FALSE_;
501       C2F(intersci).ntypes[*lw - 1] = '$';
502       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
503       C2F(intersci).lad[*lw - 1] = *lr;
504       break;
505     case 'I' :
506       it = *lr ; /* on entry lr gives the int type */
507       if (! C2F(creimat)(fname, &lw1, &it, m, n, lr, nlgh))    return FALSE_;
508       C2F(intersci).ntypes[*lw - 1] = '$';
509       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
510       C2F(intersci).lad[*lw - 1] = *lr;
511       break;
512     case 'h' :
513       if (! C2F(crehmat)(fname, &lw1, m, n, lr, nlgh))    return FALSE_;
514       C2F(intersci).ntypes[*lw - 1] = Type;
515       C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
516       C2F(intersci).lad[*lw - 1] = *lr;
517       break;
518           // TODO : add a default case
519     }
520   return TRUE_;
521 }
522
523 /*---------------------------------------------------------------------
524  *     create a variable number lw in the stack of type
525  *     type and size m,n
526  *     the argument must be of type type ('d','r','i')
527  *     return values m,n,lr
528  *     d,r,i : matrix of double,float or integer
529  *     side effects : arguments in the common intersci are modified
530  *     see examples in addinter-examples
531  *     Like createvar but for complex matrices
532  *---------------------------------------------------------------------*/
533
534 int C2F(createcvar)(integer *lw, char *typex,integer *it,integer *m,integer *n,integer *lr,integer *lc,unsigned long type_len)
535 {
536   unsigned char Type = *typex ;
537   integer lw1;
538   char *fname = Get_Iname();
539   if (*lw > intersiz) {
540     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createcvar");
541     return FALSE_;
542   }
543   Nbvars = Max(*lw,Nbvars);
544   lw1 = *lw + Top - Rhs;
545   if (*lw < 0) {
546   Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createcvar");
547     return FALSE_;
548   }
549   switch ( Type )  {
550   case 'd' :
551     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, lc, nlgh))  return FALSE_;
552     C2F(intersci).ntypes[*lw - 1] = Type;
553     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
554     C2F(intersci).lad[*lw - 1] = *lr;
555     break;
556   case 'r' :
557     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, lc, nlgh))  return FALSE_;
558     *lr = iadr(*lr);
559     *lc = *lr + *m * *n;
560     C2F(intersci).ntypes[*lw - 1] = Type;
561     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
562     C2F(intersci).lad[*lw - 1] = *lr;
563     break;
564   case 'i' :
565     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, lc, nlgh))  return FALSE_;
566     *lr = iadr(*lr);
567     *lc = *lr + *m * *n;
568     C2F(intersci).ntypes[*lw - 1] = Type;
569     C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
570     C2F(intersci).lad[*lw - 1] = *lr;
571     break;
572   }
573   return TRUE_;
574 }
575
576 /*---------------------------------------------------------------------
577  *     create a variable number lw on the stack of type
578  *     list with nel elements
579  *---------------------------------------------------------------------*/
580
581 int C2F(createlist)(integer *lw,integer *nel)
582 {
583   char *fname = Get_Iname();
584   integer lr, lw1;
585   if (*lw > intersiz) {
586         Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createlist");
587     return FALSE_;
588   }
589   Nbvars = Max(*lw,Nbvars);
590   lw1 = *lw + Top - Rhs;
591   if (*lw < 0) {
592         Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createlist");
593     return FALSE_;
594   }
595   C2F(crelist)(&lw1, nel, &lr);
596   C2F(intersci).ntypes[*lw - 1] = '$';
597   C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
598   C2F(intersci).lad[*lw - 1] = lr;
599   return TRUE_;
600 }
601
602 /*---------------------------------------------------------------------
603  *     create a variable number lw on the stack of type
604  *     type and size m,n
605  *     the argument must be of type type ('c','d','r','i','b')
606  *     return values m,n,lr,lar
607  *     lar is also an input value
608  *     if lar != -1 var is filled with data stored at lar
609  *---------------------------------------------------------------------*/
610
611 int C2F(createvarfrom)(integer *lw,char *typex,integer *m,integer *n,integer *lr,integer *lar,unsigned long type_len)
612 {
613   int M=*m,N=*n,MN=M*N;
614   unsigned char Type = *typex;
615   integer inc=1;
616   integer it=0, lw1, lcs;
617   char *fname = Get_Iname();
618   if (*lw > intersiz) {
619     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createvarfrom");
620     return FALSE_;
621   }
622   Nbvars = Max(*lw,Nbvars);
623   lw1 = *lw + Top - Rhs;
624   if (*lw < 0) {
625         Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createvarfrom");
626     return FALSE_;
627   }
628   switch ( Type ) {
629   case 'c' :
630     if (! C2F(cresmat2)(fname, &lw1, &MN, lr, nlgh)) return FALSE_;
631     if (*lar != -1)  C2F(cvstr1)(&MN, istk(*lr), cstk(*lar), &cx0,  MN + 1);
632     *lar = *lr;
633     *lr = cadr(*lr);
634     M=MN; N= 1;
635     break;
636   case 'd' :
637     if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh))  return FALSE_;
638     if (*lar != -1)  C2F(dcopy)(&MN, stk(*lar), &cx1, stk(*lr), &cx1);
639     *lar = *lr;
640     break;
641   case 'r' :
642     if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh)) return FALSE_;
643     if (*lar != -1)   C2F(rea2db)(&MN, sstk(*lar), &cx1, stk(*lr), & cx1);
644     *lar = *lr;
645     *lr = iadr(*lr);
646     break;
647   case 'i' :
648     if (! C2F(cremat)(fname, &lw1, &it, m, n, lr, &lcs, nlgh)) return FALSE_;
649     if (*lar != -1) C2F(int2db)(&MN,istk(*lar), &cx1, stk(*lr), &cx1);
650     *lar = *lr;
651     *lr = iadr(*lr);
652     break;
653   case 'b' :
654     if (! C2F(crebmat)(fname, &lw1, m, n, lr, nlgh)) return FALSE_;
655     if (*lar != -1) C2F(icopy)(&MN, istk(*lar), &cx1, istk(*lr), &cx1);
656     *lar = *lr;
657     break;
658   case 'I' :
659     it = *lr;
660     if (! C2F(creimat)(fname, &lw1, &it, m, n, lr,  nlgh))  return FALSE_;
661     if (*lar != -1)
662       C2F(tpconv)(&it,&it,&MN,istk(*lar), &inc,istk(*lr), &inc);
663     *lar = *lr;
664     break;
665   case 'p' :
666     MN=1;
667     if (! C2F(crepointer)(fname, &lw1, lr, nlgh))    return FALSE_;
668     if (*lar != -1)  C2F(dcopy)(&MN, stk(*lar), &cx1, stk(*lr), &cx1);
669     *lar = *lr;
670     break;
671   case 'h' :
672     if (! C2F(crehmat)(fname, &lw1, m, n, lr, nlgh))  return FALSE_;
673     if (*lar != -1)  C2F(dcopy)(&MN, stk(*lar), &cx1, stk(*lr), &cx1);
674     *lar = *lr;
675     break;
676   }
677   C2F(intersci).ntypes[*lw - 1] = '$';
678   C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
679   C2F(intersci).lad[*lw - 1] = *lr;
680   return TRUE_;
681 }
682
683
684 /*---------------------------------------------------------------------
685  *     create a variable number lw on the stack of type
686  *     type and size m,n
687  *     the argument must be of type type ('d','r','i')
688  *     return values it,m,n,lr,lc,lar,lac
689  *     lar is also an input value
690  *     if lar != -1 var is filled with data stored at lar
691  *     idem for lac
692  *     ==> like createvarfrom for complex matrices
693 *---------------------------------------------------------------------*/
694
695 int C2F(createcvarfrom)(integer *lw,char *typex,integer *it,integer *m,integer *n,integer *lr,integer *lc,integer *lar,integer *lac,unsigned long type_len)
696 {
697   unsigned char Type = *typex;
698   int MN;
699   integer lw1, lcs;
700   char *fname =     Get_Iname();
701   if (*lw > intersiz) {
702     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createcvarfrom");
703     return FALSE_;
704   }
705   Nbvars = Max(*lw,Nbvars);
706   lw1 = *lw + Top - Rhs;
707   MN = (*m)*(*n);
708   if (*lw < 0) {
709     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createcvarfrom");
710     return FALSE_;
711   }
712   switch ( Type ) {
713   case 'd' :
714     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, lc, nlgh)) return FALSE_;
715     if (*lar != -1) C2F(dcopy)(&MN, stk(*lar), &cx1,stk(*lr) , &cx1);
716     if (*lac != -1 && *it == 1) C2F(dcopy)(&MN, stk(*lac), &cx1,stk(*lc) , &cx1);
717     *lar = *lr;
718     *lac = *lc;
719     break;
720   case 'r' :
721     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, lc, nlgh)) return FALSE_;
722     if (*lar != -1) C2F(rea2db)(&MN, sstk(*lar), &cx1, stk(*lr), &cx1);
723     if (*lac != -1 && *it==1) C2F(rea2db)(&MN, sstk(*lac), &cx1, stk(*lc), &cx1);
724     *lar = *lr;
725     *lac = *lc;
726     *lr = iadr(*lr);
727     *lc = *lr + *m * *n;
728     break ;
729   case 'i' :
730     if (! C2F(cremat)(fname, &lw1, it, m, n, lr, &lcs, nlgh)) return FALSE_;
731     if (*lar != -1) C2F(int2db)(&MN, istk(*lar), &cx1, stk(*lr), & cx1);
732     if (*lac != -1 && (*it==1)) C2F(int2db)(&MN, istk(*lac), &cx1, stk(*lc), &cx1);
733     *lar = *lr;
734     *lac = *lc;
735     *lr = iadr(*lr);
736     *lc = *lr + *m * *n;
737     break;
738   }
739   C2F(intersci).ntypes[*lw - 1] = '$';
740   C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
741   C2F(intersci).lad[*lw - 1] = *lr;
742   return TRUE_;
743 }
744
745 /*---------------------------------------------------------------------
746  *     This function must be called after createvar(lnumber,'l',...)
747  *     Argument lnumber is a list
748  *     we want here to get its argument number number
749  *     the argument must be of type type ('c','d','r','i','b')
750  *     input values lnumber,number,type,lar
751  *     lar : input value ( -1 or the adress of an object which is used
752  *           to fill the new variable data slot.
753  *     lar must be a variable since it is used as input and output
754  *     return values m,n,lr,lar
755  *         (lar --> data is coded at stk(lar)
756  *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
757  *                  or cstk(lr)
758  *     c : string  (m-> number of characters and n->1)
759  *     d,r,i : matrix of double,float or integer
760  *---------------------------------------------------------------------*/
761
762 int C2F(createlistvarfrom)(integer *lnumber,integer *number,char * typex,integer *m,integer *n,integer *lr,integer *lar,unsigned long type_len)
763 {
764   unsigned Type = *typex;
765   integer lc, ix1, it = 0, mn = (*m)*(*n),inc=1;
766   char *fname = Get_Iname();
767   if (*lnumber > intersiz) {
768     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createlistvar");
769     return FALSE_;
770   }
771   switch ( Type ) {
772   case 'c' :
773     *n = 1;
774     ix1 = *lnumber + Top - Rhs;
775     if (! C2F(listcrestring)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, lr, nlgh)) {
776       return FALSE_;
777     }
778     if (*lar != -1) C2F(cvstr1)(m, istk(*lr), cstk(*lar), &cx0,  *m * *n + 1);
779     *lar = *lr;
780     *lr = cadr( *lr);
781     break;
782   case 'd' :
783     ix1 = *lnumber + Top - Rhs;
784     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
785                           &it, m, n, lr, &lc, nlgh)) {
786       return FALSE_;
787     }
788     if (*lar != -1) C2F(dcopy)(&mn, stk(*lar), &cx1,stk(*lr) , &cx1);
789     *lar = *lr;
790     break;
791   case 'r' :
792     ix1 = *lnumber + Top - Rhs;
793     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
794                           &it, m, n, lr, &lc, nlgh)) {
795       return FALSE_;
796     }
797     if (*lar != -1)     C2F(rea2db)(&mn, sstk(*lar), &cx1, stk(*lr), &cx1);
798     *lar = *lr;
799     *lr = iadr(*lr);
800     break;
801   case 'i' :
802     ix1 = *lnumber + Top - Rhs;
803     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
804                           &it, m, n, lr, &lc, nlgh)) {
805       return FALSE_;
806     }
807     if (*lar != -1)     C2F(int2db)(&mn, istk(*lar), &cx1, stk(*lr), &cx1);
808     *lar = *lr;
809     *lr = iadr(*lr);
810     break;
811   case 'b' :
812     ix1 = *lnumber + Top - Rhs;
813     if (! C2F(listcrebmat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1]
814                            , m, n, lr, nlgh)) {
815       return FALSE_;
816     }
817     if (*lar != -1) C2F(icopy)(&mn, istk(*lar), &cx1, istk(*lr), &cx1);
818     *lar = *lr;
819     break;
820   case 'I' :
821     it = *lr ; /* it gives the type on entry */
822     ix1 = *lnumber + Top - Rhs;
823     if (! C2F(listcreimat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
824                           &it, m, n, lr, nlgh)) {
825       return FALSE_;
826     }
827     if (*lar != -1)
828       C2F(tpconv)(&it,&it,&mn,istk(*lar), &inc,istk(*lr), &inc);
829     *lar = *lr;
830     break;
831   case 'p' :
832     ix1 = *lnumber + Top - Rhs;
833     if (! C2F(listcrepointer)(fname, &ix1, number,
834                               &C2F(intersci).lad[*lnumber - 1], lr, nlgh))
835       {
836         return FALSE_;
837       }
838     if (*lar != -1) *stk(*lr)= *stk(*lar);
839     *lar = *lr;
840     break;
841   case 'h' :
842     ix1 = *lnumber + Top - Rhs;
843     if (! C2F(listcrehmat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
844                            m, n, lr, nlgh)) {
845       return FALSE_;
846     }
847     if (*lar != -1) C2F(dcopy)(&mn, stk(*lar), &cx1,stk(*lr) , &cx1);
848     *lar = *lr;
849     break;
850   default :
851     Scierror(999,_("%s : (%s) bad third argument!\n"),fname,"createlistvar");
852     return FALSE_;
853     break;
854   }
855   return TRUE_;
856 }
857
858
859
860 /*---------------------------------------------------------------------
861  * create a complex list variable from data
862  *---------------------------------------------------------------------*/
863
864 int C2F(createlistcvarfrom)(integer *lnumber, integer *number, char *typex, integer *it, integer *m,integer *n,integer *lr,integer *lc,integer *lar,integer *lac, unsigned long type_len)
865 {
866   integer ix1;
867   int mn = (*m)*(*n);
868   unsigned char Type = *typex;
869   char *fname = Get_Iname();
870
871   if (*lnumber > intersiz) {
872     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createlistcvar");
873     return FALSE_;
874   }
875
876   switch ( Type ) {
877   case 'd' :
878     ix1 = *lnumber + Top - Rhs;
879     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],it, m, n, lr, lc, nlgh))
880       return FALSE_;
881     if (*lar != -1) C2F(dcopy)(&mn,  stk(*lar), &cx1, stk(*lr), &cx1);
882     if (*lac != -1 && *it==1) C2F(dcopy)(&mn, stk(*lac), &cx1,stk(*lc) , &cx1);
883     *lar = *lr;
884     *lac = *lc;
885     break;
886   case 'r' :
887     ix1 = *lnumber + Top - Rhs;
888     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
889                           it, m, n, lr, lc, nlgh))
890       return FALSE_;
891     if (*lar != -1) C2F(rea2db)(&mn, sstk(*lar), &cx1, stk(*lr), &cx1);
892     if (*lac != -1 && *it==1) C2F(rea2db)(&mn, sstk(*lac), &cx1, stk(*lc), & cx1);
893     *lar = *lr;
894     *lac = *lc;
895     *lr = iadr(*lr);
896     *lc = *lr + *m * *n;
897     break;
898   case 'i' :
899     ix1 = *lnumber + Top - Rhs;
900     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
901                           it, m, n, lr, lc, nlgh))
902       return FALSE_;
903     if (*lar != -1) C2F(int2db)(&mn,istk(*lar), &cx1, stk(*lr), &cx1);
904     if (*lac != -1 && *it==1) C2F(int2db)(&mn, istk(*lac), &cx1, stk(*lc), &cx1);
905     *lar = *lr;
906     *lac = *lc;
907     *lr = iadr(*lr);
908     *lc = *lr + *m * *n;
909     break;
910   default :
911     Scierror(999,_("%s : (%s) bad third argument!\n"),fname,"createlistcvar");
912     return FALSE_;
913   }
914   return TRUE_;
915 }
916
917
918
919 /*---------------------------------------------------------------------
920  *     This function must be called after createvar(lnumber,'l',...)
921  *     Argument lnumber is a list
922  *     we want here to get its argument number number
923  *     the argument must be of type type ('c','d','r','i','b')
924  *     input values lnumber,number,type,lar
925  *     lar : input value ( -1 or the adress of an object which is used
926  *           to fill the new variable data slot.
927  *     lar must be a variable since it is used as input and output
928  *     return values m,n,lr,lar
929  *         (lar --> data is coded at stk(lar)
930  *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
931  *                  or cstk(lr)
932  *     c : string  (m-> number of characters and n->1)
933  *     d,r,i : matrix of double,float or integer
934  *---------------------------------------------------------------------*/
935
936 int C2F(createlistvarfromptr)(integer *lnumber,integer * number,char *typex,integer *m,integer *n,void *iptr,unsigned long type_len)
937 {
938   unsigned Type = *typex;
939   integer lc, ix1, it = 0, lr,inc=1;
940   char *fname = Get_Iname();
941   if (*lnumber > intersiz) {
942     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createlistvarfromptr");
943     return FALSE_;
944   }
945
946   ix1 = *lnumber + Top - Rhs;  /* factorization of this term (Bruno 9 march 2005, bugfix ) */
947   switch ( Type ) {
948   case 'c' :
949     *n = 1;
950     if (! C2F(listcrestring)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1], m, &lr, nlgh)) {
951       return FALSE_;
952     }
953     C2F(cchar)(m,(char **) iptr, istk(lr));
954     break;
955   case 'd' :
956     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
957                           &it, m, n, &lr, &lc, nlgh)) {
958       return FALSE_;
959     }
960     ix1= (*m)*(*n);
961     C2F(cdouble) (&ix1,(double **) iptr, stk(lr));
962     break;
963   case 'r' :
964     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
965                           &it, m, n, &lr, &lc, nlgh)) {
966       return FALSE_;
967     }
968     ix1= (*m)*(*n);
969     C2F(cfloat) (&ix1,(float **) iptr, stk(lr));
970     break;
971   case 'i' :
972     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
973                           &it, m, n, &lr, &lc, nlgh)) {
974       return FALSE_;
975     }
976     ix1 = *m * *n;
977     C2F(cint)(&ix1,(int **) iptr, stk(lr));
978     break;
979   case 'b' :
980     if (! C2F(listcrebmat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1]
981                            , m, n, &lr, nlgh)) {
982       return FALSE_;
983     }
984     ix1 = *m * *n;
985     C2F(cbool)(&ix1,(int **) iptr, istk(lr));
986     break;
987   case 'S' :
988     if ( !cre_listsmat_from_str(fname,&ix1, number, &C2F(intersci).lad[*lnumber - 1]
989                                 , m, n, (char **) iptr, nlgh)) /* XXX */
990       return FALSE_;
991     break;
992   case 's' :
993     if ( !cre_listsparse_from_ptr(fname,&ix1,number,
994                               &C2F(intersci).lad[*lnumber - 1]
995                               , m, n, (SciSparse *) iptr, nlgh))
996       return FALSE_;
997     break;
998   case 'I' :
999     it = ((SciIntMat *) iptr)->it;
1000     if (! C2F(listcreimat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
1001                           &it, m, n, &lr, nlgh)) {
1002       return FALSE_;
1003     }
1004     ix1= (*m)*(*n);
1005     C2F(tpconv)(&it,&it,&ix1,((SciIntMat *) iptr)->D, &inc,istk(lr), &inc);
1006     break;
1007   case 'p' :
1008     if (! C2F(listcrepointer)(fname, &ix1, number,
1009                               &C2F(intersci).lad[*lnumber - 1],&lr,nlgh))
1010       {
1011         return FALSE_;
1012       }
1013     *stk(lr) = (double) ((unsigned long int) iptr);
1014     break;
1015   default :
1016     Scierror(999,_("%s : (%s) bad third argument!\n"),fname,"createlistcvar");
1017     return FALSE_;
1018     break;
1019   }
1020   return TRUE_;
1021 }
1022
1023
1024 /*---------------------------------------------------------------------
1025  *     This function must be called after createvar(lnumber,'l',...)
1026  *     Argument lnumber is a list
1027  *     we want here to get its argument number number
1028  *     the argument must be of type type ('c','d','r','i','b')
1029  *     input values lnumber,number,type,lar
1030  *     lar : input value ( -1 or the adress of an object which is used
1031  *           to fill the new variable data slot.
1032  *     lar must be a variable since it is used as input and output
1033  *     return values m,n,lr,lar
1034  *         (lar --> data is coded at stk(lar)
1035  *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
1036  *                  or cstk(lr)
1037  *     c : string  (m-> number of characters and n->1)
1038  *     d,r,i : matrix of double,float or integer
1039  *---------------------------------------------------------------------*/
1040
1041 int C2F(createlistcvarfromptr)(integer *lnumber,integer *number,char *typex,integer *it,integer *m,integer *n,void *iptr,void *iptc,unsigned long type_len)
1042 {
1043   unsigned Type = *typex;
1044   integer lr,lc, ix1;
1045   char *fname = Get_Iname();
1046   if (*lnumber > intersiz) {
1047     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createlistvarfromptr");
1048     return FALSE_;
1049   }
1050   switch ( Type ) {
1051   case 'd' :
1052     ix1 = *lnumber + Top - Rhs;
1053     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
1054                           it, m, n, &lr, &lc, nlgh)) {
1055       return FALSE_;
1056     }
1057     ix1= (*m)*(*n);
1058     C2F(cdouble) (&ix1,(double **) iptr, stk(lr));
1059     if ( *it == 1) C2F(cdouble) (&ix1,(double **) iptc, stk(lc));
1060     break;
1061   case 'r' :
1062     ix1 = *lnumber + Top - Rhs;
1063     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
1064                           it, m, n, &lr, &lc, nlgh)) {
1065       return FALSE_;
1066     }
1067     ix1= (*m)*(*n);
1068     C2F(cfloat) (&ix1,(float **) iptr, stk(lr));
1069     if ( *it == 1)     C2F(cfloat) (&ix1,(float **) iptc, stk(lc));
1070     break;
1071   case 'i' :
1072     ix1 = *lnumber + Top - Rhs;
1073     if (! C2F(listcremat)(fname, &ix1, number, &C2F(intersci).lad[*lnumber - 1],
1074                           it, m, n, &lr, &lc, nlgh)) {
1075       return FALSE_;
1076     }
1077     ix1 = *m * *n;
1078     C2F(cint)(&ix1,(int **) iptr, stk(lr));
1079     if ( *it == 1)     C2F(cint)(&ix1,(int **) iptc, stk(lc));
1080     break;
1081   default :
1082     Scierror(999,_("%s : (%s) bad third argument!\n"),fname,"createlistcvarfromptr");
1083     return FALSE_;
1084     break;
1085   }
1086   return TRUE_;
1087 }
1088
1089
1090 /*---------------------------------------------------------------------
1091  * use the rest of the stack as working area
1092  * the allowed size (in double) is returned in m
1093  *---------------------------------------------------------------------*/
1094
1095 int C2F(creatework)(integer *number,integer *m,integer *lr)
1096 {
1097   int n,it=0,lw1,lcs,il;
1098   char *fname = Get_Iname();
1099   if (*number > intersiz) {
1100
1101     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"creatework");
1102     return FALSE_ ;
1103   }
1104   Nbvars = Max(*number,Nbvars);
1105   lw1 = *number + Top - Rhs;
1106   if (lw1 < 0) {
1107         Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"creatework");
1108     return FALSE_ ;
1109   }
1110   il = iadr(*Lstk(lw1));
1111   *m = *Lstk(Bot ) - sadr(il+4);
1112   n = 1;
1113   if (! C2F(cremat)(fname, &lw1, &it, m, &n, lr, &lcs, nlgh))    return FALSE_;
1114   return TRUE_;
1115 }
1116
1117
1118 /*---------------------------------------------------------------------
1119  * This can be used with creatework to
1120  * set the size of object which was intialy sized to the whole
1121  * remaining space with creatework
1122  * Moreover informations the objet is recorded
1123  *---------------------------------------------------------------------*/
1124
1125 int C2F(setworksize)(integer *number,integer *size)
1126 {
1127   int lw1;
1128   char *fname = Get_Iname();
1129   if (*number > intersiz) {
1130         Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"creatework");
1131     return FALSE_ ;
1132   }
1133   Nbvars = Max(*number,Nbvars);
1134   lw1 = *number + Top - Rhs;
1135   if (lw1 < 0) {
1136     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"setworksize");
1137     return FALSE_ ;
1138   }
1139   *istk(iadr(*Lstk(lw1)))=0;
1140   *Lstk(lw1+1) = *Lstk(lw1) + *size ;
1141   C2F(intersci).ntypes[*number - 1] = '$';
1142   C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1143   C2F(intersci).lad[*number - 1] = 0; /* not to be used XXXX */
1144   return TRUE_;
1145 }
1146
1147
1148 /*---------------------------------------------------------------------
1149  * getmatdims :
1150  *     check if argument number <<number>> is a matrix and
1151  *     returns its dimensions
1152  *---------------------------------------------------------------------*/
1153
1154 int C2F(getmatdims)(integer *number,integer *m,integer *n)
1155 {
1156   char *fname = Get_Iname();
1157   integer il,lw,typ;
1158
1159   lw = *number + Top - Rhs;
1160   if ( *number > Rhs) {
1161     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"getmatdims");
1162     return FALSE_;
1163   }
1164
1165   il = iadr(*Lstk(lw));
1166   if (*istk(il ) < 0) il = iadr(*istk(il +1));
1167   typ = *istk(il );
1168   if (typ > sci_strings) {
1169     Scierror(199,_("%s : argument %d should be a matrix.\n"), fname,*number);
1170     return  FALSE_;
1171   }
1172   *m = *istk(il + 1);
1173   *n = *istk(il + 2);
1174   return TRUE_;
1175 }
1176
1177 /*---------------------------------------------------------------------
1178  * getrhsvar :
1179  *     get the argument number <<number>>
1180  *     the argument must be of type type ('c','d','r','i','f','l','b')
1181  *     return values m,n,lr
1182  *     c : string  (m-> number of characters and n->1)
1183  *     d,r,i : matrix of double,float or integer
1184  *     f : external (function)
1185  *     b : boolean matrix
1186  *     l : a list  (m-> number of elements and n->1)
1187  *         for each element of the list an other function
1188  *         must be used to <<get>> them
1189  *     side effects : arguments in the common intersci are modified
1190  *     see examples in addinter-examples
1191  *---------------------------------------------------------------------*/
1192
1193 int C2F(getrhsvar)(integer *number,char *typex,integer *m,integer *n,integer *lr,unsigned long type_len)
1194 {
1195   int ierr=0,il1,ild1,nn;
1196   int lrr;
1197   char *fname = Get_Iname();
1198   char **items, namex[nlgh+1];
1199   unsigned char Type = *(unsigned char *) typex;
1200   integer topk,ltype, m1, n1, lc,lr1, it=0, lw, ile, ils, ix1,ix2;
1201   integer mnel,icol;
1202   SciSparse *Sp;
1203   SciIntMat *Im;
1204   /* we accept a call to getrhsvar after a createvarfromptr call */
1205   if ( *number > Rhs && *number > Nbvars ) {
1206     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"getrhsvar");
1207     return FALSE_;
1208   }
1209
1210   Nbvars = Max(Nbvars,*number);
1211   lw = *number + Top - Rhs;
1212
1213   if (*number > intersiz) {
1214         Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"getrhsvar");
1215     return FALSE_;
1216   }
1217
1218   if (overloadtype(&lw,fname,&Type) == 0) return FALSE_;
1219
1220   topk = Top;
1221   switch ( Type )
1222     {
1223     case 'c' :
1224       *n = 1;
1225       if (! C2F(getsmat)(fname,&topk,&lw,&m1,&n1,&cx1,&cx1,lr,m, nlgh))
1226         return FALSE_;
1227       ix2 = *m * *n;
1228       /* in case where ix2 is 0 in2str adds the \0 char after the end of
1229          the storage of the variable, so it writes over the next variable
1230          tp avoid this pb we shift up by one the location where the
1231          data is written*/
1232       lrr=*lr;
1233       if (ix2==0) lrr--;
1234
1235       C2F(in2str)(&ix2, istk(*lr), cstk(cadr(*lr)), ix2 + 1);
1236       *lr = cadr(*lr);
1237       C2F(intersci).ntypes[*number - 1] = Type ;
1238       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1239       C2F(intersci).lad[*number - 1] = *lr;
1240       break;
1241
1242     case 'd' :
1243       if (! C2F(getmat)(fname, &topk, &lw, &it, m, n, lr, &lc, nlgh)) return FALSE_;
1244       C2F(intersci).ntypes[*number - 1] = Type ;
1245       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1246       C2F(intersci).lad[*number - 1] = *lr;
1247       break ;
1248     case 'z' :
1249       if (! C2F(getmat)(fname, &topk, &lw, &it, m, n, lr, &lc, nlgh)) return FALSE_;
1250       ix2 = *m * *n;
1251       if ((it != 1) && (ix2 !=0))
1252           {
1253                 Scierror(999,_("Waiting for a complex argument(z).\n"));
1254                 return FALSE_;
1255       };
1256       if (!(*lr % 2) ) {  /* bad adress (lr is even) shift up the stack */
1257         double2z(stk(*lr), stk(*lr)-1, ix2, ix2);
1258         *istk(iadr(*lr)-4)=133;
1259         *istk(iadr(*lr)-3)=iadr(*lr + 2*ix2-1);
1260         *istk( iadr(*lr + 2*ix2-1) )= *m;
1261         *istk( iadr(*lr + 2*ix2-1) +1 )= *n;
1262         C2F(intersci).ntypes[*number - 1] = Type ;
1263         C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1264         C2F(intersci).lad[*number - 1] = *lr-1;
1265         *lr = sadr(*lr-1);
1266       }
1267       else {
1268         SciToF77(stk(*lr), ix2, ix2);
1269         C2F(intersci).ntypes[*number - 1] = Type ;
1270         C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1271         C2F(intersci).lad[*number - 1] = *lr;
1272         *lr = sadr(*lr);
1273       };
1274       break ;
1275     case 'r' :
1276       if (! C2F(getmat)(fname, &topk, &lw, &it, m, n, lr, &lc, nlgh))  return FALSE_;
1277       ix1 = *m * *n;
1278       C2F(simple)(&ix1, stk(*lr), sstk(iadr(*lr)));
1279       *lr = iadr(*lr);
1280       C2F(intersci).ntypes[*number - 1] = Type ;
1281       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1282       C2F(intersci).lad[*number - 1] = *lr;
1283       break;
1284     case 'i' :
1285       if (! C2F(getmat)(fname, &topk, &lw, &it, m, n, lr, &lc, nlgh)) return FALSE_;
1286       ix1 = *m * *n;
1287       C2F(entier)(&ix1, stk(*lr), istk(iadr(*lr)));
1288       *lr = iadr(*lr) ;
1289       C2F(intersci).ntypes[*number - 1] = Type ;
1290       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1291       C2F(intersci).lad[*number - 1] = *lr;
1292       break;
1293     case 'b' :
1294       if (! C2F(getbmat)(fname, &topk, &lw, m, n, lr, nlgh))  return FALSE_;
1295       C2F(intersci).ntypes[*number - 1] = Type ;
1296       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1297       C2F(intersci).lad[*number - 1] = *lr;
1298       break;
1299     case 'l' :    case 't' :    case 'm' :
1300       *n = 1;
1301       if (! C2F(getilist)(fname, &topk, &lw, m, n, lr, nlgh))  return FALSE_;
1302       /* No data conversion for list members ichar(type)='$' */
1303       Type = '$' ;
1304       C2F(intersci).ntypes[*number - 1] = Type ;
1305       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1306       C2F(intersci).lad[*number - 1] = *lr;
1307       break;
1308     case 'S' :
1309       /** getwsmat : must be back in stack1.c from xawelm.f */
1310       if (! C2F(getwsmat)(fname,&topk,&lw,m,n,&il1,&ild1, nlgh)) return FALSE_;
1311       nn= (*m)*(*n);
1312       ScilabMStr2CM(istk(il1),&nn,istk(ild1),&items,&ierr);
1313       if ( ierr == 1) return FALSE_;
1314       Type = '$';
1315       /*
1316        * Warning : lr must have the proper size when calling getrhsvar
1317        * char **Str1; .... GetRhsVar(...., &lr)
1318        */
1319       *((char ***) lr) = items ;
1320       C2F(intersci).ntypes[*number - 1] = Type ;
1321       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1322       C2F(intersci).lad[*number - 1] = *lr;
1323       break;
1324     case 's' :
1325       /* sparse matrices */
1326       Sp = (SciSparse *) lr ;
1327       if (! C2F(getsparse)(fname,&topk,&lw,&it,m,n,&(Sp->nel),&mnel,&icol,&lr1,&lc,nlgh))
1328         return FALSE_;
1329       Sp->m = *m ; Sp->n = *n ; Sp->it = it;
1330       Sp->mnel = istk(mnel);
1331       Sp->icol = istk(icol);
1332       Sp->R = stk(lr1);
1333       Sp->I = (it==1) ? stk(lc): NULL;
1334       Type = '$';
1335       C2F(intersci).ntypes[*number - 1] = Type ;
1336       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1337       C2F(intersci).lad[*number - 1] = *lr;
1338       break;
1339     case 'I' :
1340       /* int matrices */
1341       Im = (SciIntMat *) lr ;
1342       if (! C2F(getimat)(fname,&topk,&lw,&it,m,n,&lr1,nlgh))
1343         return FALSE_;
1344       Im->m = *m ; Im->n = *n ; Im->it = it; Im->l = lr1;
1345       Im->D = istk(lr1);
1346       Type = '$';
1347       C2F(intersci).ntypes[*number - 1] = Type ;
1348       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1349       C2F(intersci).lad[*number - 1] = *lr;
1350       break;
1351     case 'f' :
1352       /* XXXXXX : gros bug ici car getexternal a besoin de savoir
1353          pour quelle fonction on recupere un external
1354          or ici on presuppose que c'est setfeval
1355          de plus on ne sait pas exactement de quel type d'external il s'agit
1356       */
1357
1358       /*      int function getrhsvar(number,type,m,n,lr) */
1359       *lr = *Lstk(lw);
1360       ils = iadr(*lr) + 1;
1361       *m = *istk(ils);
1362       ile = ils + *m * nsiz + 1;
1363       *n = *istk(ile);
1364       if (! C2F(getexternal)(fname, &topk, &lw, namex, &ltype, C2F(setfeval), nlgh,
1365                              nlgh)) {
1366         return FALSE_;
1367       }
1368       Type = '$';
1369       C2F(intersci).ntypes[*number - 1] = Type ;
1370       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1371       C2F(intersci).lad[*number - 1] = *lr;
1372       break;
1373     case 'p' :
1374       if (! C2F(getpointer)(fname, &topk, &lw,lr, nlgh)) return FALSE_;
1375       C2F(intersci).ntypes[*number - 1] = Type ;
1376       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1377       C2F(intersci).lad[*number - 1] = *lr;
1378       break;
1379     case 'h' :
1380       if (! C2F(gethmat)(fname, &topk, &lw, m, n, lr, nlgh)) return FALSE_;
1381       C2F(intersci).ntypes[*number - 1] = Type ;
1382       C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1383       C2F(intersci).lad[*number - 1] = *lr;
1384       break ;
1385     }
1386   return TRUE_;
1387 }
1388
1389
1390 /*---------------------------------------------------------------------
1391  * getrhsvcar :
1392  *     get the argument number <<number>>
1393  *     the argument must be of type type ('d','r','i')
1394  *     like getrhsvar but for complex matrices
1395  *---------------------------------------------------------------------*/
1396
1397 int C2F(getrhscvar)(integer *number,char *typex,integer *it,integer *m,integer *n,integer *lr,integer *lc,unsigned long type_len)
1398 {
1399   integer ix1, lw, topk;
1400   unsigned char Type = *typex;
1401   char *fname = Get_Iname();
1402
1403   Nbvars = Max(Nbvars,*number);
1404   lw = *number + Top - Rhs;
1405   if (*number > Rhs) {
1406     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"getrhscvar");
1407     return FALSE_;
1408   }
1409   if (*number > intersiz) {
1410         Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"getrhscvar");
1411     return FALSE_;
1412   }
1413   topk = Top;
1414   switch ( Type ) {
1415   case 'd' :
1416     if (! C2F(getmat)(fname, &topk, &lw, it, m, n, lr, lc, nlgh)) return FALSE_;
1417     break;
1418   case 'r' :
1419     if (! C2F(getmat)(fname, &topk, &lw, it, m, n, lr, lc, nlgh)) return FALSE_;
1420     ix1 = *m * *n * (*it + 1);
1421     C2F(simple)(&ix1, stk(*lr), sstk(iadr(*lr)));
1422     *lr = iadr(*lr);
1423     *lc = *lr + *m * *n;
1424     break;
1425   case 'i' :
1426     if (! C2F(getmat)(fname, &topk, &lw, it, m, n, lr, lc, nlgh)) return FALSE_;
1427     ix1 = *m * *n * (*it + 1);
1428     C2F(entier)(&ix1, stk(*lr), istk(iadr(*lr)));
1429     *lr = iadr(*lr);
1430     *lc = *lr + *m * *n;
1431     break;
1432   }
1433   C2F(intersci).ntypes[*number - 1] = Type;
1434   C2F(intersci).iwhere[*number - 1] = *Lstk(lw);
1435   C2F(intersci).lad[*number - 1] = *lr;
1436   return TRUE_;
1437 }
1438 /*---------------------------------------------------------------------
1439  * elementtype:
1440  *   returns the type of the element indexed by *number in the list
1441  *   whose variable number is *lnumber. If the indexed element does not exist
1442  *   the function returns 0.
1443  *---------------------------------------------------------------------*/
1444
1445 int C2F(elementtype)(integer *lnumber, integer *number)
1446 {
1447   integer il,lw,itype,n,ix,ili;
1448   char *fname = Get_Iname();
1449
1450   if (*lnumber > Rhs) {
1451     Scierror(999,_("%s : bad call to elementtype!\n"),fname);
1452     return FALSE_;
1453   }
1454
1455   lw = *lnumber + Top - Rhs; /*index of the variable numbered *lnumber in the stack */
1456   il = iadr(*Lstk(lw));
1457   if (*istk(il) < 0) il = iadr(*istk(il + 1));
1458   itype = *istk(il ); /* type of the variable numbered *lnumber */
1459   if (itype <  sci_list || itype > sci_mlist) { /* check if it is really a list */
1460     Scierror(210,_("%s : Argument %d: wrong type argument, expecting a list.\n"),fname,*lnumber);
1461     return FALSE_;
1462   }
1463   n = *istk(il + 1);/* number of elements in the list */
1464   itype = 0; /*default answer if *number is not a valid element index */
1465   if (*number<=n && *number>0) {
1466     ix = sadr(il + 3 + n); /* adress of the first list element */
1467     if (*istk(il + 1+ *number) < *istk(il + *number + 2)) { /* the required element is defined */
1468       ili = iadr(ix + *istk(il + 1+ *number) - 1); /* adress of the required element */
1469       itype = *istk(ili);
1470     }
1471   }
1472   return itype;
1473 }
1474
1475 /*---------------------------------------------------------------------
1476  *     This function must be called after getrhsvar(lnumber,'l',...)
1477  *     Argument lnumber is a list
1478  *     we want here to get its argument number number
1479  *     the argument must be of type type ('c','d','r','i','b')
1480  *     return values m,n,lr,lar
1481  *         (lar --> data is coded at stk(lar)
1482  *          lr  --> data is coded at istk(lr) or stk(lr) or sstk(lr)
1483  *                  or cstk(lr)
1484  *     c : string  (m-> number of characters and n->1)
1485  *     d,r,i : matrix of double,float or integer
1486  *---------------------------------------------------------------------*/
1487
1488 int C2F(getlistrhsvar)(integer *lnumber,integer *number,char *typex,integer *m,integer *n,integer *lr,unsigned long type_len)
1489 {
1490   int lr1;
1491   char **items;
1492   int il1,ild1,nn,ierr=0;
1493   char *fname = Get_Iname();
1494   integer m1, n1, lc, it, lw, topk = Top, ix1,ix2;
1495   unsigned char Type = *typex;
1496   integer mnel,icol;
1497   SciSparse *Sp;
1498   SciIntMat *Im;
1499
1500   Nbvars = Max(Nbvars,*lnumber);
1501   lw = *lnumber + Top - Rhs;
1502   if (*lnumber > Rhs) {
1503     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"getlistrhsvar");
1504     return FALSE_;
1505   }
1506   if (*lnumber > intersiz) {
1507     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"getlistrhsvar");
1508     return FALSE_;
1509   }
1510
1511   switch ( Type ) {
1512   case 'c' :
1513     *n = 1;
1514     if (! C2F(getlistsimat)(fname, &topk, &lw, number, &m1, &n1, &cx1, &cx1,lr, m, nlgh))
1515       return FALSE_;
1516     ix2 = *m * *n;
1517     C2F(in2str)(&ix2, istk(*lr), cstk(cadr(*lr)), ix2 + 1);
1518     *lr = cadr(*lr);
1519     break;
1520   case 'd' :
1521     if (! C2F(getlistmat)(fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1522       return FALSE_;
1523     break;
1524   case 'r' :
1525     if (! C2F(getlistmat)(fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1526       return FALSE_;
1527     ix1 = *m * *n;
1528     C2F(simple)(&ix1, stk(*lr), sstk(iadr(*lr)));
1529     *lr = iadr(*lr);
1530     break;
1531   case 'i' :
1532     if (! C2F(getlistmat)(fname, &topk, &lw, number, &it, m, n, lr, &lc, nlgh))
1533       return FALSE_;
1534     ix1 = *m * *n;
1535     C2F(entier)(&ix1, stk(*lr), istk(iadr(*lr)));
1536     *lr = iadr(*lr);
1537     break;
1538   case 'b' :
1539     if (! C2F(getlistbmat)(fname, &topk, &lw, number, m, n, lr, nlgh))
1540       return FALSE_;
1541     *lr = *lr;
1542     break;
1543   case 'z' :
1544     if (! C2F(getlistmat)(fname, &topk, &lw,number, &it, m, n, lr, &lc, nlgh)) return FALSE_;
1545     ix2 = *m * *n;
1546     if ((it != 1) && (ix2 !=0)){
1547       Scierror(999,_("%s : argument %d > (%d) should be a complex matrix.\n"),fname, Rhs + (lw -topk) , *number);
1548       return FALSE_;
1549     };
1550       if (!(*lr % 2) ) {  /* bad adress (lr is even) shift up the stack */
1551         double2z(stk(*lr), stk(*lr)-1, ix2, ix2);
1552         ix2=2*ix2;
1553         *istk(iadr(*lr)-4)=133;
1554         *istk(iadr(*lr)-3)=iadr(*lr + ix2);
1555         *istk( iadr(*lr + ix2) )= *m;
1556         *istk( iadr(*lr + ix2) +1 )= *n;
1557         *lr = sadr(*lr-1);
1558       } else
1559         {
1560       SciToF77(stk(*lr), ix2, ix2);
1561       *lr = sadr(*lr);
1562         }
1563     break;
1564   case 'S' :
1565     /** getwsmat : must be back in stack1.c from xawelm.f */
1566     if (! C2F(getlistwsmat)(fname,&topk,&lw,number,m,n,&il1,&ild1, nlgh)) return FALSE_;
1567     nn= (*m)*(*n);
1568     ScilabMStr2CM(istk(il1),&nn,istk(ild1),&items,&ierr);
1569     if ( ierr == 1) return FALSE_;
1570     Type = '$';
1571     /*
1572      * Warning : lr must have the proper size when calling getrhsvar
1573      * char **Str1; .... GetRhsVar(...., &lr)
1574      */
1575     *((char ***) lr) = items ;
1576     break;
1577   case 's' :
1578     /* sparse matrices */
1579     Sp = (SciSparse *) lr ;
1580     if (! C2F(getlistsparse)(fname,&topk,&lw,number,&it,m,n,&(Sp->nel),&mnel,&icol,&lr1,&lc,nlgh))
1581       return FALSE_;
1582     Sp->m = *m ; Sp->n = *n ; Sp->it = it;
1583     Sp->mnel = istk(mnel);
1584     Sp->icol = istk(icol);
1585     Sp->R = stk(lr1);
1586     Sp->I = stk(lc);
1587     Type = '$';
1588     break;
1589   case 'I' :
1590     /* int matrices */
1591     Im = (SciIntMat *) lr ;
1592     if (! C2F(getlistimat)(fname,&topk,&lw,number,&it,m,n,&lr1,nlgh))
1593       return FALSE_;
1594     Im->m = *m ; Im->n = *n ; Im->it = it; Im->l = lr1;
1595     Im->D = istk(lr1);
1596     Type = '$';
1597     break;
1598   case 'p' :
1599     if (! C2F(getlistpointer)(fname, &topk, &lw, number, lr,  nlgh))
1600       return FALSE_;
1601     break;
1602   default :
1603     Scierror(999,_("%s : bad call to %s (third argument %c).\n"),fname,"getlistrhsvar",Type);
1604     return FALSE_;
1605   }
1606   /* can't perform back data conversion with lists */
1607   C2F(intersci).ntypes[*number - 1] = '$';
1608   return TRUE_ ;
1609 }
1610
1611 /*---------------------------------------------------------------------
1612  * for complex
1613  *---------------------------------------------------------------------*/
1614
1615 int C2F(getlistrhscvar)(integer *lnumber,integer *number,char *typex,integer *it,integer *m,integer *n,integer *lr,integer *lc,unsigned long type_len)
1616 {
1617   integer ix1, topk= Top, lw;
1618   char *fname = Get_Iname();
1619   unsigned  char    Type = * typex;
1620
1621   Nbvars = Max(Nbvars,*lnumber);
1622   lw = *lnumber + Top - Rhs;
1623   if (*lnumber > Rhs) {
1624     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"getlistrhscvar");
1625     return FALSE_;
1626   }
1627   if (*lnumber > intersiz) {
1628     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"getlistrhscvar");
1629     return FALSE_;
1630   }
1631   switch ( Type ) {
1632   case 'd' :
1633     if (! C2F(getlistmat)(fname, &topk, &lw, number, it, m, n, lr, lc, nlgh)) return FALSE_;
1634     break;
1635   case 'r' :
1636     if (! C2F(getlistmat)(fname, &topk, &lw, number, it, m, n, lr, lc, nlgh))
1637       return FALSE_;
1638     ix1 = *m * *n * (*it + 1);
1639     C2F(simple)(&ix1, stk(*lr), sstk(iadr(*lr)));
1640     *lr  = iadr(*lr);
1641     *lc = *lr + *m * *n;
1642     break;
1643   case 'i' :
1644     if (! C2F(getlistmat)(fname, &topk, &lw, number, it, m, n, lr, lc, nlgh))
1645       return FALSE_;
1646     ix1 = *m * *n * (*it + 1);
1647     C2F(entier)(&ix1, stk(*lr), istk(iadr(*lr)));
1648     *lr = iadr(*lr) ;
1649     *lc = *lr + *m * *n;
1650     break;
1651   default :
1652     Scierror(999,_("%s : (%s) bad third argument!\n"),fname,"getlistrhscvar");
1653
1654     return FALSE_;
1655   }
1656   /* can't perform back data conversion with lists */
1657   C2F(intersci).ntypes[*number - 1] = '$';
1658   return TRUE_;
1659 }
1660
1661 /*---------------------------------------------------------------------
1662  *     creates variable number number of type "type" and dims m,n
1663  *     from pointer ptr
1664  *
1665  *---------------------------------------------------------------------*/
1666
1667 int C2F(createvarfromptr)(integer *number,char *typex,integer *m,integer *n,void *iptr,unsigned long type_len)
1668 {
1669         static int un=1;
1670         unsigned char Type = *typex;
1671         int MN= (*m)*(*n),lr,it,lw1;
1672         char *fname = Get_Iname();
1673         lw1 = *number + Top - Rhs;
1674         switch ( Type )
1675                 {
1676                         case 'd' :
1677                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1678                                 C2F(dcopy)(&MN,*((double **) iptr),&un, stk(lr),&un);
1679                                 break;
1680                         case 'i' :
1681                         case 'b' :
1682                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1683                                 C2F(icopy)(&MN,*((int **) iptr), &un, istk(lr), &un);
1684                                 break;
1685                         case 'r' :
1686                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1687                                 C2F(rcopy)(&MN,*((float **)iptr), &un, sstk(lr), &un);
1688                                 break;
1689                         case 'c' :
1690                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1691                                 strcpy(cstk(lr),*((char **) iptr));
1692                                 break;
1693                         case 'I' :
1694                                 /* on entry lr must gives the int type */
1695                                 it = lr = ((SciIntMat *) iptr)->it;
1696                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1697                                 C2F(tpconv)(&it,&it,&MN,((SciIntMat *) iptr)->D, &un,istk(lr), &un);
1698                                 break;
1699                         case 'p' :
1700                                 if ( C2F(createvar)(number, typex, m, n, &lr, type_len) == FALSE_ ) return FALSE_;
1701                                 *stk(lr) = (double) ((unsigned long int) iptr);
1702                                 break;
1703                         case 'S' :
1704                                 /* special case: not taken into account in createvar */
1705                                 Nbvars = Max(*number,Nbvars);
1706                                 if ( !cre_smat_from_str(fname,&lw1, m, n, (char **) iptr, nlgh))
1707                                         return FALSE_;
1708                                 C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1709                                 C2F(intersci).ntypes[*number - 1] = '$';
1710                                 break;
1711                         case 's' :
1712                                 /* special case: not taken into account in createvar */
1713                                 Nbvars = Max(*number,Nbvars);
1714                                 if ( !cre_sparse_from_ptr(fname,&lw1, m, n, (SciSparse *) iptr, nlgh))
1715                                         return FALSE_;
1716                                 C2F(intersci).iwhere[*number - 1] = *Lstk(lw1);
1717                                 C2F(intersci).ntypes[*number - 1] = '$';
1718                                 break;
1719                         default :
1720                                 Scierror(999,_("%s : (%s) bad second argument!\n"),fname,"createvarfromptr");
1721
1722                                 return FALSE_;
1723                 }
1724         /*     this object will be copied with a vcopyobj in putlhsvar */
1725         return TRUE_;
1726 }
1727
1728
1729
1730 /*---------------------------------------------------------------------
1731  *     for complex
1732  *---------------------------------------------------------------------*/
1733
1734 int C2F(createcvarfromptr)(integer *number,char *typex,integer *it,integer *m,integer *n,double *iptr,double *iptc,unsigned long type_len)
1735 {
1736   unsigned char Type = *typex;
1737   char *fname = Get_Iname();
1738   integer lw1, lcs, lrs, ix1;
1739
1740   Nbvars = Max(Nbvars,*number);
1741   if (*number > intersiz) {
1742     Scierror(999,_("%s : createcvarfromptr: too many arguments on the stack, enlarge intersiz.\n"),fname);
1743     return FALSE_;
1744   }
1745   lw1 = *number + Top - Rhs;
1746   switch ( Type ) {
1747   case 'd' :
1748     if (! C2F(cremat)(fname, &lw1, it, m, n, &lrs, &lcs, nlgh))
1749       return FALSE_;
1750     ix1 = *m * *n;
1751     C2F(cdouble)(&ix1, (double **) iptr, stk(lrs));
1752     if (*it == 1) {
1753       ix1 = *m * *n;
1754       C2F(cdouble)(&ix1,(double **) iptc, stk(lcs));
1755     }
1756     break;
1757   case 'i' :
1758     if (! C2F(cremat)(fname, &lw1, it, m, n, &lrs, &lcs, nlgh))
1759       return FALSE_;
1760     ix1 = *m * *n;
1761     C2F(cint)(&ix1, (int **) iptr, stk(lrs));
1762     if (*it == 1) {
1763       ix1 = *m * *n;
1764       C2F(cint)(&ix1,(int **) iptc, stk(lcs));
1765     }
1766     break;
1767   default :
1768         Scierror(999,_("%s : (%s) bad second argument!\n"),fname,"createcvarfromptr");
1769                                 
1770     return FALSE_;
1771   }
1772   /*     this object will be copied with a vcopyobj in putlhsvar */
1773   C2F(intersci).ntypes[*number - 1] = '$';
1774   return  TRUE_;
1775 }
1776
1777 /*---------------------------------------------------------------------
1778  * mklistfromvars :
1779  *     replace the last n variables created at postions pos:pos-1+n
1780  *     by a list of these variables at position pos
1781  *---------------------------------------------------------------------*/
1782
1783 int C2F(mklistfromvars)(integer *pos,integer *n)
1784 {
1785   integer tops =  Top;
1786   int k;
1787   for ( k= *pos; k < *pos+*n; k++) C2F(convert2sci)(&k);
1788   Top = Top - Rhs + *pos - 1 + *n;
1789   C2F(mklist)(n);
1790   Top = tops;
1791   C2F(intersci).ntypes[*pos - 1] = '$';
1792   return  TRUE_;
1793 }
1794 /*---------------------------------------------------------------------
1795  * mktlistfromvars :
1796  *     similar to mklistfromvars but create a tlist
1797  *---------------------------------------------------------------------*/
1798
1799 int C2F(mktlistfromvars)(integer *pos,integer *n)
1800 {
1801   integer type=16;
1802   integer tops =  Top;
1803   int k;
1804   for ( k= *pos; k < *pos+*n; k++) C2F(convert2sci)(&k);
1805   Top = Top - Rhs + *pos - 1 + *n;
1806   C2F(mklistt)(n,&type);
1807   Top = tops;
1808   C2F(intersci).ntypes[*pos - 1] = '$';
1809   return  TRUE_;
1810 }
1811 /*---------------------------------------------------------------------
1812  * mktlistfromvars :
1813  *     similar to mklistfromvars but create a mlist
1814  *---------------------------------------------------------------------*/
1815
1816 int C2F(mkmlistfromvars)(integer *pos,integer *n)
1817 {
1818   integer type=sci_mlist;
1819   integer tops =  Top;
1820   int k;
1821   for ( k= *pos; k < *pos+*n; k++) C2F(convert2sci)(&k);
1822   Top = Top - Rhs + *pos - 1 + *n;
1823   C2F(mklistt)(n,&type);
1824   Top = tops;
1825   C2F(intersci).ntypes[*pos - 1] = '$';
1826   return  TRUE_;
1827 }
1828
1829 /*---------------------------------------------------------------------
1830  * call a Scilab function given its name
1831  *---------------------------------------------------------------------*/
1832
1833 int C2F(callscifun)(char *string,unsigned long string_len)
1834 {
1835   integer id[nsiz];
1836   C2F(cvname)(id, string, &cx0, string_len);
1837   C2F(putid)(&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], id);
1838   C2F(com).fun = -1;
1839   return 0;
1840 }
1841
1842 /*---------------------------------------------------------------------
1843  * scifunction(number,ptr,mlhs,mrhs) >
1844  *     execute scilab function with mrhs input args and mlhs output
1845  *     variables
1846  *     input args are supposed to be stored in the top of the stack
1847  *     at positions top-mrhs+1:top
1848  *---------------------------------------------------------------------*/
1849
1850 int C2F(scifunction)(integer *number,integer *ptr,integer *mlhs,integer *mrhs)
1851 {
1852   integer cx26 = 26;
1853   integer ix1, krec, ix, k, intop, il, ir, lw;
1854
1855   if ( intersci_push() == 0 )
1856     {
1857       Scierror(999,_("%s: No more memory available.\n"),"scifunction");
1858       goto L9999;
1859     }
1860
1861   /*     macro execution */
1862   intop = Top;
1863   Top = Top - Rhs + *number + *mrhs - 1;
1864   ++C2F(recu).pt;
1865   if (C2F(recu).pt > psiz) {
1866     C2F(error)(&cx26);
1867     goto L9999;
1868   }
1869   C2F(recu).ids[C2F(recu).pt * nsiz - nsiz] = Lhs;
1870   C2F(recu).ids[C2F(recu).pt * nsiz - (nsiz-1)] = Rhs;
1871   C2F(recu).rstk[C2F(recu).pt - 1] = 1001;
1872   Lhs = *mlhs;
1873   Rhs = *mrhs;
1874   ++C2F(recu).niv;
1875   C2F(com).fun = 0;
1876   Fin = *ptr;
1877   C2F(recu).icall = 5;
1878   krec = -1;
1879
1880  L60:
1881   C2F(parse)();
1882   if (C2F(com).fun == 99) {
1883     C2F(com).fun = 0;
1884     goto L200;
1885   }
1886   if (Err > 0)  goto L9999;
1887   if (C2F(recu).rstk[C2F(recu).pt - 1] / 100 == 9) {
1888     ir = C2F(recu).rstk[C2F(recu).pt - 1] - 900;
1889     if (ir == 1) {
1890       /*     .     back to matsys */
1891       k = 13;
1892     } else if (ir >= 2 && ir <= 9) {
1893       /*     .     back to matio */
1894       k = 5;
1895       /*<          elseif(ir.eq.10) then >*/
1896     } else if (ir == 10) {
1897       /*     .     end of overloaded function */
1898       goto L96;
1899       /*<          elseif(ir.gt.40) then >*/
1900     } else if (ir > 40) {
1901       /*     .     back to matus2 */
1902       k = 24;
1903     } else if (ir > 20) {
1904       /*     .     back to matusr */
1905       k = 14;
1906     } else {
1907       goto L89;
1908     }
1909     goto L95;
1910   }
1911
1912  L89:
1913   if (Top < Rhs) {
1914           Scierror(22,_("%s : recursion problems. Sorry ...\n"),"scifunction");
1915     goto L9999;
1916   }
1917   if (Top - Rhs + Lhs + 1 >= Bot) {
1918     Scierror(18,_("%s : too many names.\n"),"scifunction");
1919     goto L9999;
1920   }
1921   goto L91;
1922  L90:
1923   if (Err > 0) {
1924     goto L9999;
1925   }
1926   if (Top - Lhs + 1 > 0) {
1927     C2F(iset)(&Lhs, &cx0, &C2F(vstk).infstk[Top - Lhs], &cx1);
1928   }
1929  L91:
1930   k = C2F(com).fun;
1931   C2F(com).fun = 0;
1932   if (k == krec) {
1933     Scierror(22,_("%s : recursion problems. Sorry ...\n"),"scifunction");
1934     goto L9999;
1935   }
1936   if (k == 0) {
1937     goto L60;
1938   }
1939   if (k == 2) {
1940     il = iadr( *Lstk(Top + 1 - Rhs));
1941   }
1942  L95:
1943   if (! C2F(allowptr)(&k)) {
1944     C2F(ref2val)();
1945   }
1946   C2F(callinterf)(&k);
1947   if (C2F(com).fun >= 0) {
1948     goto L90;
1949   }
1950   /*    called interface ask for a scilab function to perform the function (fun=-1)
1951    *     the function name is given in ids(1,pt+1)
1952    */
1953   C2F(ref2val)();
1954   C2F(com).fun = 0;
1955   C2F(funs)(&C2F(recu).ids[(C2F(recu).pt + 1)* nsiz - nsiz]);
1956   if (Err > 0) {
1957     goto L9999;
1958   }
1959   if (C2F(com).fun > 0) {
1960     goto L91;
1961   }
1962   if (Fin == 0) {
1963     integer cx4 = 4;
1964     C2F(error)(&cx4);
1965     if (Err > 0) {
1966       goto L9999;
1967     }
1968     goto L90;
1969   }
1970   ++C2F(recu).pt;
1971   Fin = *Lstk(C2F(com).fin);
1972   C2F(recu).rstk[C2F(recu).pt - 1] = 910;
1973   C2F(recu).icall = 5;
1974   C2F(com).fun = 0;
1975   /*     *call*  macro */
1976   goto L60;
1977  L96:
1978   --C2F(recu).pt;
1979   goto L90;
1980  L200:
1981   Lhs = C2F(recu).ids[C2F(recu).pt * nsiz -nsiz ];
1982   Rhs = C2F(recu).ids[C2F(recu).pt * nsiz -(nsiz-1)];
1983   --C2F(recu).pt;
1984   --C2F(recu).niv;
1985   /* + */
1986   Top = intop;
1987   ix1 = *mlhs;
1988   intersci_pop();
1989   for (ix = 1; ix <= ix1; ++ix) {
1990     lw = Top - Rhs + *number + ix - 1;
1991     C2F(intersci).ntypes[lw - 1] = '$';
1992   }
1993   return TRUE_;
1994
1995  L9999:
1996   Top = intop;
1997   --C2F(recu).niv;
1998   intersci_pop();
1999   return FALSE_;
2000 }
2001
2002 /*---------------------------------------------------------------------
2003  * scistring :
2004  *   executes scilab string (name of a scilab function) with mrhs
2005  *     input args and mlhs output variables
2006  *     input args are supposed to be indexed by ifirst,ifirst+1,...
2007  *     thestring= string made of the name of a Scilab function
2008  *     mlhs,mlhs = number of lhs and rhs parameters of the function
2009  *     ifisrt,thestring,mlhs and mrhs are input parameters.
2010  *---------------------------------------------------------------------*/
2011
2012 int C2F(scistring)(integer *ifirst,char *thestring,integer *mlhs,integer *mrhs,unsigned long thestring_len)
2013 {
2014   int ret = FALSE_;
2015   integer ifin, ifun, tops, moutputs, id[nsiz], lf, op, ile, ils, nnn, ninputs;
2016   nnn =  thestring_len;
2017   op = 0;
2018   if (nnn <= 2) {
2019     op = C2F(getopcode)(thestring, thestring_len);
2020   }
2021   if (op == 0) {
2022     C2F(cvname)(id, thestring, &cx0, nnn);
2023     Fin = 0;
2024     tops = Top;
2025     Top = Top - Rhs + *ifirst + *mrhs - 1;
2026     C2F(funs)(id);
2027     Top = tops;
2028     if (Fin == 0)
2029         {
2030       Scierror(999,_("scistring: %s is not a Scilab function.\n"),get_fname(thestring,thestring_len));
2031       return ret;
2032     }
2033     if (C2F(com).fun <= 0) {
2034       lf = *Lstk(Fin);
2035       ils = iadr(lf) + 1;
2036       moutputs = *istk(ils);
2037       ile = ils + moutputs * nsiz + 1;
2038       ninputs = *istk(ile);
2039       /*
2040        *   ninputs=actual number of inputs, moutputs=actual number of outputs
2041        *   of thestring: checking mlhs=ninputs and mrhs=moutputs not done.
2042        */
2043       ret = C2F(scifunction)(ifirst, &lf, mlhs, mrhs);
2044     } else {
2045       ifin = Fin;
2046       ifun = C2F(com).fun;
2047       ret = C2F(scibuiltin)(ifirst, &ifun, &ifin, mlhs, mrhs);
2048     }
2049   } else {
2050     ret = C2F(sciops)(ifirst, &op, mlhs, mrhs);
2051   }
2052   return ret;
2053 }
2054
2055 integer C2F(getopcode)(char *string,unsigned long string_len)
2056 {
2057   unsigned char ch = string[0];
2058   integer op = 0;
2059   if (  string_len >= 2) {
2060     /*     .op  or op. */
2061     if ( ch  == '.') ch = string[1];
2062     op += 51;
2063   }
2064   switch ( ch )
2065     {
2066     case  '*'  :  op += 47; break;
2067     case  '+'  :  op += 45; break;
2068     case  '-'  :  op += 46; break;
2069     case  '\'' :  op += 53; break;
2070     case  '/'  :  op += 48; break;
2071     case  '\\' :  op += 49; break;
2072     case  '^'  :  op += 62; break;
2073     }
2074   return op;
2075 }
2076
2077 /*---------------------------------------------------------------------
2078  *     same as scifunction: executes scilab built-in function (ifin,ifun)
2079  *
2080  *     =(interface-number, function-nmber-in-interface)
2081  *     for the input parameters located at number, number+1, ....
2082  *     mlhs,mrhs = # of lhs and rhs parameters of the function.
2083  *---------------------------------------------------------------------*/
2084
2085 int C2F(scibuiltin)(integer *number,integer *ifun,integer *ifin,integer *mlhs,integer *mrhs)
2086 {
2087   integer krec, srhs, slhs;
2088   integer ix, k, intop, il, ir, lw, pt0;
2089   intop = Top;
2090
2091   if ( intersci_push() == 0 )
2092     {
2093       Scierror(999,_("%s: No more memory available.\n"),"scifunction");
2094       goto L9999;
2095     }
2096
2097   Top = Top - Rhs + *number + *mrhs - 1;
2098   slhs = Lhs;
2099   srhs = Rhs;
2100   Lhs = *mlhs;
2101   Rhs = *mrhs;
2102   krec = -1;
2103   pt0 = C2F(recu).pt;
2104   goto L90;
2105   /* ***************************** */
2106   /*<  60   call  parse >*/
2107  L60:
2108   C2F(parse)();
2109   if (C2F(com).fun == 99) {
2110     C2F(com).fun = 0;
2111     goto L200;
2112   }
2113   if (Err > 0) {
2114     goto L9999;
2115   }
2116   if (C2F(recu).rstk[C2F(recu).pt - 1] / 100 == 9) {
2117     ir = C2F(recu).rstk[C2F(recu).pt - 1] - 900;
2118     if (ir == 1) {
2119       /*     .     back to matsys */
2120       k = 13;
2121     } else if (ir >= 2 && ir <= 9) {
2122       /*     .     back to matio */
2123       k = 5;
2124     } else if (ir == 10) {
2125       /*     .     end of overloaded function */
2126       goto L96;
2127     } else if (ir > 40) {
2128       /*     .     back to matus2 */
2129       k = 24;
2130     } else if (ir > 20) {
2131       /*     .     back to matusr */
2132       k = 14;
2133     } else {
2134       goto L89;
2135     }
2136     goto L95;
2137   }
2138  L89:
2139   if (Top < Rhs) {
2140     Scierror(22,_("%s : recursion problems. Sorry ...\n"),_("built in"));
2141     goto L9999;
2142   }
2143   if (Top - Rhs + Lhs + 1 >= Bot) {
2144     Scierror(18,_("%s : too many names.\n"),"");
2145     goto L9999;
2146   }
2147   goto L91;
2148  L90:
2149   if (Err > 0) {
2150     goto L9999;
2151   }
2152   if (Top - Lhs + 1 > 0) {
2153     C2F(iset)(&Rhs, &cx0, &C2F(vstk).infstk[Top - Lhs], &cx1);
2154   }
2155  L91:
2156   k = C2F(com).fun;
2157   C2F(com).fun = 0;
2158   if (k == krec) {
2159     Scierror(22,_("%s : recursion problems. Sorry ...\n"),_("built in"));
2160     goto L9999;
2161   }
2162   if (k == 0) {
2163     if (C2F(recu).pt > pt0) {
2164       goto L60;
2165     }
2166     goto L200;
2167   }
2168   if (k == 2) {
2169     il = iadr(*Lstk(Top + 1 - Rhs));
2170   }
2171   if (! C2F(allowptr)(&k)) {
2172     C2F(ref2val)();
2173   }
2174  L95:
2175   C2F(callinterf)(&k);
2176   if (C2F(recu).icall != 0) {
2177     goto L60;
2178   }
2179   if (C2F(com).fun >= 0) {
2180     goto L90;
2181   }
2182   /*    called interface ask for a sci function to perform the function (fun=-1)*/
2183   /*     the function name is given in ids(1,pt+1) */
2184   C2F(ref2val)();
2185   C2F(com).fun = 0;
2186   C2F(funs)(&C2F(recu).ids[(C2F(recu).pt + 1)* nsiz - nsiz]);
2187   if (Err > 0) {
2188     goto L9999;
2189   }
2190   if (C2F(com).fun > 0) {
2191     goto L91;
2192   }
2193   if (Fin == 0) {
2194     integer cx4 = 4;
2195     C2F(error)(&cx4);
2196     if (Err > 0) {
2197       goto L9999;
2198     }
2199   }
2200   ++C2F(recu).pt;
2201   Fin = *Lstk(C2F(com).fin);
2202   C2F(recu).rstk[C2F(recu).pt - 1] = 910;
2203   C2F(recu).icall = 5;
2204   C2F(com).fun = 0;
2205   /*     *call*  macro */
2206   goto L60;
2207  L96:
2208   --C2F(recu).pt;
2209   goto L90;
2210   /* ************************** */
2211  L200:
2212   Lhs = slhs;
2213   Rhs = srhs;
2214   Top = intop;
2215   intersci_pop();
2216   for (ix = 0 ; ix < *mlhs ; ++ix) {
2217     lw = Top - Rhs + *number + ix ;
2218     C2F(intersci).ntypes[lw - 1] = '$';
2219   }
2220   return TRUE_;
2221  L9999:
2222   intersci_pop();
2223   return FALSE_;
2224 }
2225
2226 /*---------------------------------------------------------------------
2227  *     same as scibuiltin: executes scilab operation op
2228  *     for the input parameters located at number, number+1, ....
2229  *     mlhs,mrhs = # of lhs and rhs parameters of the operation.
2230  *---------------------------------------------------------------------*/
2231
2232 int C2F(sciops)(integer *number,integer *op,integer *mlhs,integer *mrhs)
2233 {
2234   integer ifin, ifun, srhs= Rhs , slhs= Lhs, ix, intop=Top , lw;
2235
2236   Fin   = *op;
2237   Top = Top - Rhs + *number + *mrhs - 1;
2238   Lhs = *mlhs;
2239   Rhs = *mrhs;
2240
2241   while (1)
2242     {
2243       C2F(allops)();
2244       if (Err > 0) {return FALSE_;} ;
2245       if (C2F(com).fun == 0) break;
2246       Top = intop;
2247       ifun = C2F(com).fun;
2248       ifin = Fin;
2249       if (! C2F(scibuiltin)(number, &ifun, &ifin, mlhs, mrhs))
2250         {return FALSE_;} ;
2251       if (Err > 0) {return FALSE_;} ;
2252     }
2253   Lhs = slhs;
2254   Rhs = srhs;
2255   Top = intop;
2256
2257   for (ix = 1 ; ix <= *mlhs ; ++ix) {
2258     lw = Top - Rhs + *number + ix - 1;
2259     C2F(intersci).ntypes[lw - 1] = '$';
2260   }
2261   C2F(com).fun = 0;
2262   Fin = *op;
2263   C2F(recu).icall = 0;
2264   return TRUE_;
2265 }
2266
2267 /*-------------------------------------------------------------
2268  *     test and return linear system (syslin tlist)
2269  *     inputs: lw = variable number
2270  *     outputs:
2271  *     N=size of A matrix (square)
2272  *     M=number of inputs = col. dim B matrix
2273  *     P=number of outputs = row. dim of C matrix
2274  *     ptr(A,B,C,D,X0) adresses of A,B,C,D,X0 in stk
2275  *     h=type   h=0.0  continuous system
2276  *              h=1.0  discrete time system
2277  *              h=h    sampled system h=sampling period
2278  -------------------------------------------------------------*/
2279
2280 int C2F(getrhssys)(integer *lw,integer *n,integer *m,integer *p,integer *ptra,integer *ptrb,integer *ptrc,integer *ptrd,integer *ptrx0,double *hx)
2281 {
2282   integer cx2 = 2, cx3 = 3, cx4 = 4, cx5 = 5, cx6 = 6;
2283   integer ix1, junk, msys, nsys, ix, icord;
2284   integer ma, na, mb, nb, mc, nc, il, md, nd;
2285   integer mx0, nx0, ptrsys, itimedomain;
2286   static integer iwork[23] = { 10,1,7,0,1,4,5,6,7,8,10,12,21,28,28,-10,-11,
2287                                -12,-13,-33,0,13,29 };
2288   if (! C2F(getrhsvar)(lw, "t", &msys, &nsys, &ptrsys, 1L)) return FALSE_;
2289   il = iadr(ptrsys) - msys - 1;
2290   /*     syslin tlist=[ chain, (A,B,C,D,X0) ,chain or scalar ]
2291    *                     10     1 1 1 1 1      10       1
2292    */
2293   junk = il + msys + iadr(*istk(il));
2294   if ( *istk(junk) != 10) return FALSE_;
2295   if ( *istk(il + msys + iadr(*istk(il + 1))) != 1) return FALSE_;
2296   if ( *istk(il + msys + iadr(*istk(il + 2))) != 1) return FALSE_;
2297   if ( *istk(il + msys + iadr(*istk(il + 3))) != 1) return FALSE_;
2298   if ( *istk(il + msys + iadr(*istk(il + 4))) != 1) return FALSE_;
2299   if ( *istk(il + msys + iadr(*istk(il + 5))) != 1) return FALSE_;
2300   itimedomain = *istk(il + msys + iadr(*istk(il + 6)));
2301   switch ( itimedomain ) {
2302   case sci_strings :
2303     /* Sys(7)='c' or 'd' */
2304     icord = *istk(il + msys + iadr(*istk(il + 6))+ 6);
2305     switch ( icord )
2306       {
2307       case 12 :  *hx = 0.; break;
2308       case 13 :  *hx = 1.; break;
2309       default :
2310         Scierror(999,_("Invalid time domain.\n"));
2311         return FALSE_;
2312       }
2313     break;
2314   case sci_matrix :
2315     /*     Sys(7)=h */
2316     ix1 = il + msys + iadr(*istk(il + 6)) + 4;
2317     *hx = *stk(sadr(ix1));
2318     break;
2319   default :
2320     Scierror(999,_("Invalid time domain.\n"));
2321     return FALSE_;
2322   }
2323   for (ix = 0; ix < 23; ++ix)
2324     {
2325       if (iwork[ix] != *istk(junk + ix)) {
2326         Scierror(999,_("Invalid system.\n"));
2327         return FALSE_;
2328       }
2329     }
2330   if (! C2F(getlistrhsvar)(lw, &cx2, "d", &ma, &na, ptra, 1L)) return FALSE_;
2331   if (! C2F(getlistrhsvar)(lw, &cx3, "d", &mb, &nb, ptrb, 1L)) return FALSE_;
2332   if (! C2F(getlistrhsvar)(lw, &cx4, "d", &mc, &nc, ptrc, 1L)) return FALSE_;
2333   if (! C2F(getlistrhsvar)(lw, &cx5, "d", &md, &nd, ptrd, 1L)) return FALSE_;
2334   if (! C2F(getlistrhsvar)(lw, &cx6, "d", &mx0, &nx0, ptrx0, 1L))  return FALSE_;
2335   if (ma != na) {
2336     Scierror(999,_("A matrix non square!\n"));
2337     return FALSE_;
2338   }
2339   if (ma != mb && mb != 0) {
2340     Scierror(999,_("Invalid %c,%c matrices.\n"),'A','B');
2341     return FALSE_;
2342   }
2343   if (ma != nc && nc != 0) {
2344     Scierror(999,_("Invalid %c,%c matrices.\n"),'A','C');
2345     return FALSE_;
2346   }
2347   if (mc != md && md != 0) {
2348     Scierror(999,_("Invalid %c,%c matrices.\n"),'C','D');
2349     return FALSE_;
2350   }
2351   if (nb != nd && nd != 0) {
2352     Scierror(999,_("Invalid %c,%c matrices.\n"),'B','D');
2353     return FALSE_;
2354   }
2355   *n = ma;
2356   *m = nb;
2357   *p = mc;
2358   return TRUE_;
2359 }
2360
2361
2362 /*---------------------------------------------------
2363  * call Scilab error function (for Fortran use)
2364  *---------------------------------------------------*/
2365
2366 int C2F(errorinfo)(char *fname,integer *info,unsigned long fname_len)
2367 {
2368   Scierror(998,_("%s : internal error, info=%d.\n"),get_fname(fname,fname_len),*info);
2369   return 0;
2370 }
2371
2372
2373 /*-------------------------------------------------------------
2374  *  returns Maximal available size in scilab stack
2375  *  for variable <<number>> lw
2376  *  In a Fortran call
2377  *     lw =
2378  *     type= 'd','r','i','c'
2379  *     type_len is here for C/Fortran calling conventions
2380  *  This function is used for creating a working array of Maximal dimension
2381  *  Example :
2382  *     lwork=Maxvol(nb,'d')
2383  *     if(.not.createvar(nb,'d',lwork,1,idwork)) return
2384  *     call pipo(   ,stk(idwork),[lwork],...)
2385  *-------------------------------------------------------------*/
2386
2387 integer C2F(maxvol)(integer *lw,char *lw_type,unsigned long type_len)
2388 {
2389   unsigned char Type =  *(unsigned char *)lw_type ;
2390   /* I like this one a lot: a kind of free jazz pattern  */
2391   integer m = *Lstk(Bot) - sadr(iadr(*Lstk(*lw + Top - Rhs)) +4);
2392   switch ( Type )
2393     {
2394     case 'd' : return m; break;
2395     case 'i' : return iadr(m);break;
2396     case 'r' : return iadr(m);break;
2397     case 'c' : return cadr(m);break;
2398     case 'z' : return sadr(m)-3;break;
2399     }
2400   /* should never get there */
2401   return m;
2402 }
2403
2404
2405 /*---------------------------------------------
2406  * This function checks all the variables which
2407  * where references and restore their contents
2408  * to Scilab value.
2409  *---------------------------------------------*/
2410
2411 static int Check_references()
2412 {
2413         int ivar ;
2414         for (ivar = 1; ivar <= Rhs ; ++ivar)
2415                 {
2416                         unsigned char Type = (unsigned char)C2F(intersci).ntypes[ivar - 1];
2417                         if ( Type != '$')
2418                                 {
2419                                         int lw = ivar + Top - Rhs;
2420                                         int il = iadr(*Lstk(lw));
2421                                         if ( *istk(il) < 0)
2422                                                 {
2423                                                         int m,n,it,size;
2424                                                         /* back conversion if necessary of a reference */
2425                                                         if ( *istk(il) < 0)  il = iadr(*istk(il +1));
2426                                                         m =*istk(il +1);
2427                                                         n =*istk(il +2);
2428                                                         it = *istk(il +3);
2429                                                         switch ( Type ) {
2430                                                                 case 'i' :
2431                                                                 case 'r' :
2432                                                                 case 'd' :
2433                                                                         size  = m * n * (it + 1); break;
2434                                                                 case 'z' :
2435                                                                         size  = 0;break; /* size is unsued for 'z' in ConvertData;*/
2436                                                                 case 'c' :
2437                                                                         size =*istk(il + 4  +1) - *istk(il + 4 ); break;
2438                                                                 case 'b' :
2439                                                                         size = m*n ; break;
2440                                                                 default:
2441                                                                         return FALSE_;
2442                                                         }
2443                                                         ConvertData(&Type,size,C2F(intersci).lad[ivar - 1]);
2444                                                         C2F(intersci).ntypes[ivar - 1] = '$';
2445                                                 }
2446                                 }
2447                         else
2448                                 {
2449                                 }
2450                 }
2451         return TRUE_;
2452 }
2453
2454
2455
2456
2457 /*---------------------------------------------------------------------
2458  * int C2F(putlhsvar)()
2459  *     This function put on the stack the lhs
2460  *     variables which are at position lhsvar(i)
2461  *     on the calling stack
2462  *     Warning : this function supposes that the last
2463  *     variable on the stack is at position top-rhs+nbvars
2464  *---------------------------------------------------------------------*/
2465
2466 int C2F(putlhsvar)()
2467 {
2468   integer ix2, ivar, ibufprec, ix, k, lcres, nbvars1;
2469   integer plhsk;
2470   Check_references();
2471
2472   for (k = 1; k <= Lhs; k++)
2473     {
2474       plhsk=*Lstk(LhsVar(k)+Top-Rhs);
2475       if (*istk( iadr(plhsk) ) < 0) {
2476         if (*Lstk(Bot) > *Lstk(*istk(iadr (plhsk) +2)) )
2477         LhsVar(k)=*istk(iadr(plhsk)+2);
2478         /* lcres = 0 */
2479       }
2480     }
2481
2482   if (Err > 0||C2F(errgst).err1> 0)  return TRUE_ ;
2483   if (C2F(com).fun== -1 ) return TRUE_ ; /* execution continue with an
2484                                             overloaded function */
2485   if (LhsVar(1) == 0)
2486     {
2487       Top = Top - Rhs + Lhs;
2488       C2F(objvide)(" ", &Top, 1L);
2489       Nbvars = 0;
2490       return TRUE_;
2491     }
2492   nbvars1 = 0;
2493   for (k = 1; k <= Lhs ; ++k) nbvars1 = Max( nbvars1 , LhsVar(k));
2494   /* check if output variabe are in increasing order in the stack */
2495   lcres = TRUE_;
2496   ibufprec = 0;
2497   for (ix = 1; ix <= Lhs ; ++ix) {
2498     if (LhsVar(ix) < ibufprec) {
2499       lcres = FALSE_;
2500       break;
2501     } else {
2502       ibufprec = LhsVar(ix );
2503     }
2504   }
2505   if (! lcres) {
2506     /* First pass if output variables are not
2507      * in increasing order
2508      */
2509     for (ivar = 1; ivar <= Lhs; ++ivar) {
2510       ix2 = Top - Rhs + nbvars1 + ivar;
2511       if (! C2F(mvfromto)(&ix2, &LhsVar(ivar))) {
2512         return FALSE_;
2513       }
2514       LhsVar(ivar) = nbvars1 + ivar;
2515       /* I change type of variable nbvars1 + ivar
2516        * in order to just perform a dcopy at next pass
2517        */
2518       if (nbvars1 + ivar > intersiz)
2519           {
2520                 Scierror(999,_("putlhsvar: intersiz is too small.\n"));
2521                 return FALSE_;
2522       }
2523       C2F(intersci).ntypes[nbvars1 + ivar - 1] = '$';
2524     }
2525   }
2526   /*  Second pass */
2527   for (ivar = 1; ivar <= Lhs ; ++ivar)
2528     {
2529       ix2 = Top - Rhs + ivar;
2530       if (! C2F(mvfromto)(&ix2, &LhsVar(ivar))) {
2531         return FALSE_;
2532       }
2533     }
2534   Top = Top - Rhs + Lhs;
2535   LhsVar(1) = 0;
2536   Nbvars = 0;
2537   return TRUE_;
2538 }
2539
2540
2541 /*---------------------------------------------------------------------
2542  * mvfromto :
2543  *     this routines copies the variable number i
2544  *     (created by getrhsvar or createvar or by mvfromto itself in a precedent call)
2545  *     from its position on the stack to position itopl
2546  *     returns false if there's no more stack space available
2547  *     - if type(i) # '$'  : This variable is at
2548  *                         position lad(i) on the stack )
2549  *                         and itopl must be the first free position
2550  *                         on the stack
2551  *                         copy is performed + type conversion (type(i))
2552  *     - if type(i) == '$': then it means that object at position i
2553  *                         is the result of a previous call to mvfromto
2554  *                         a copyobj is performed and itopl can
2555  *                         can be any used position on the stack
2556  *                         the object which was at position itopl
2557  *                         is replaced by object at position i
2558  *                         (and access to object itopl+1 can be lost if
2559  *                         the object at position i is <> from object at
2560  *                         position itopl
2561  *---------------------------------------------------------------------*/
2562
2563 static int C2F(mvfromto)(integer *itopl,integer *ix)
2564 {
2565   integer ix1=0;
2566   integer m=0;
2567   integer n=0;
2568   integer it=0;
2569   integer lcs=0;
2570   integer lrs=0;
2571   integer l=0;
2572   integer size=0;
2573   integer pointed=0;
2574   unsigned long int ilp=0;
2575   unsigned char Type;
2576   double wsave;
2577
2578   Type = (unsigned char)C2F(intersci).ntypes[*ix - 1];
2579   if ( Type != '$')
2580     {
2581       /* int iwh = *ix + Top - Rhs;
2582          ilp = iadr(*Lstk(iwh)); */
2583       int iwh = C2F(intersci).iwhere[*ix - 1];
2584       ilp = iadr(iwh);
2585       if ( *istk(ilp) < 0)  ilp = iadr(*istk(ilp +1));
2586       m =*istk(ilp +1);
2587       n =*istk(ilp +2);
2588       it = *istk(ilp +3);
2589     }
2590
2591   switch ( Type ) {
2592   case 'i' :
2593     if (! C2F(cremat)("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L)) {
2594       return FALSE_;
2595     }
2596     ix1 = m * n * (it + 1);
2597     C2F(stacki2d)(&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
2598     C2F(intersci).lad[*ix - 1] = iadr(lrs);
2599     break ;
2600   case 'r' :
2601     if (! C2F(cremat)("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L)) {
2602       return FALSE_;
2603     }
2604     ix1 = m * n * (it + 1);
2605     C2F(stackr2d)(&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
2606     C2F(intersci).lad[*ix - 1] = iadr(lrs);
2607     break;
2608   case 'd' :
2609     if (! C2F(cremat)("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L)) {
2610       return FALSE_;
2611     }
2612     /* no copy if the two objects are the same
2613      * the cremat above is kept to deal with possible size changes
2614      */
2615     if (C2F(intersci).lad[*ix - 1] != lrs) {
2616       ix1 = m * n * (it + 1);
2617       l=C2F(intersci).lad[*ix - 1];
2618       if (abs(l-lrs)<ix1)
2619         C2F(unsfdcopy)(&ix1, stk(l), &cx1, stk(lrs), &cx1);
2620       else
2621         C2F(dcopy)(&ix1, stk(l), &cx1, stk(lrs), &cx1);
2622       C2F(intersci).lad[*ix - 1] = lrs;
2623     }
2624     break;
2625   case 'z' :
2626     if ( *istk(ilp) == 133 ) {
2627       wsave=*stk(C2F(intersci).lad[*ix - 1]);
2628       n=*istk(m+1);
2629           m=*istk(m);
2630           it=1;
2631       if (! C2F(cremat)("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L)) {
2632       return FALSE_;  }
2633       z2double(stk(C2F(intersci).lad[*ix - 1]),stk(lrs),m*n, m*n);
2634       *stk(lrs)=wsave;
2635       C2F(intersci).lad[*ix - 1] = lrs;
2636       }
2637     else {
2638       if (! C2F(cremat)("mvfromto", itopl, &it, &m, &n, &lrs, &lcs, 8L)) {
2639         return FALSE_;
2640       }
2641     z2double(stk(C2F(intersci).lad[*ix - 1]), stk(lrs), m*n, m*n);
2642     C2F(intersci).lad[*ix - 1] = lrs;
2643     }
2644     break;
2645   case 'c' :
2646     m = *istk(ilp + 4  +1) - *istk(ilp + 4 );
2647     n = 1;
2648     ix1 = m * n;
2649     if (! C2F(cresmat2)("mvfromto", itopl, &ix1, &lrs, 8L)) {
2650       return FALSE_;
2651     }
2652     C2F(stackc2i)(&ix1, &C2F(intersci).lad[*ix - 1], &lrs);
2653     C2F(intersci).lad[*ix - 1] = cadr(lrs);
2654     break;
2655
2656   case 'b' :
2657     if (! C2F(crebmat)("mvfromto", itopl, &m, &n, &lrs, 8L)) {
2658       return FALSE_;
2659     }
2660     ix1 = m * n;
2661     C2F(icopy)(&ix1, istk(C2F(intersci).lad[*ix - 1]), &cx1,istk(lrs), &cx1);
2662     C2F(intersci).lad[*ix - 1] = lrs;
2663     break;
2664   case '-' :
2665     /*    reference  '-' = ascii(45) */
2666     ilp = iadr(*Lstk(*ix));
2667     size = *istk(ilp+3);
2668     pointed = *istk(ilp+2);
2669     if (! C2F(cremat)("mvfromto", itopl, (it=0 ,&it), (m=1, &m), &size, &lrs, &lcs, 8L)) {
2670       return FALSE_;
2671     }
2672     if ( C2F(vcopyobj)("mvfromto", &pointed, itopl, 8L) == FALSE_)
2673           return FALSE_;
2674     break;
2675   case 'h' :
2676     if (! C2F(crehmat)("mvfromto", itopl, &m, &n, &lrs, 8L)) {
2677       return FALSE_;
2678     }
2679     /* no copy if the two objects are the same
2680      * the cremat above is kept to deal with possible size changes
2681      */
2682     if (C2F(intersci).lad[*ix - 1] != lrs) {
2683       ix1 = m * n;
2684       l=C2F(intersci).lad[*ix - 1];
2685       if (abs(l-lrs)<ix1)
2686         C2F(unsfdcopy)(&ix1, stk(l), &cx1, stk(lrs), &cx1);
2687       else
2688         C2F(dcopy)(&ix1, stk(l), &cx1, stk(lrs), &cx1);
2689       C2F(intersci).lad[*ix - 1] = lrs;
2690     }
2691     break;
2692   case 'p' :   case '$' :
2693     /*     special case */
2694     if (Top - Rhs + *ix != *itopl)
2695       {
2696         ix1 = Top - Rhs + *ix;
2697         if ( C2F(vcopyobj)("mvfromto", &ix1, itopl, 8L) == FALSE_)
2698           return FALSE_;
2699       }
2700   }
2701   return TRUE_;
2702 }
2703
2704
2705
2706 /*---------------------------------------------------------------------
2707  * copyref
2708  * copy object at position from to position to
2709  * without changing data.
2710  * The copy is only performed if object is a reference
2711  * and ref object is replaced by its value
2712  *---------------------------------------------------------------------*/
2713
2714 int Ref2val(int from , int to )
2715 {
2716   integer il,lw;
2717   lw = from + Top - Rhs;
2718   if ( from  > Rhs)
2719   {
2720     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),"copyref","isref");
2721     return FALSE_;
2722   }
2723   il = iadr(*Lstk(lw));
2724   if ( *istk(il) < 0)
2725     {
2726       int lwd ;
2727       /* from contains a reference */
2728       lw= *istk(il+2);
2729       lwd = to + Top -Rhs;
2730       C2F(copyobj)("copyref", &lw, &lwd, (unsigned long)strlen("copyref"));
2731     }
2732   return 0;
2733 }
2734
2735 /*---------------------------------------------------------------------
2736  * convert2sci :
2737  *     this routine converts data of variable number num
2738  *     to scilab standard data code
2739  *     see how it is used in matdes.c
2740  *---------------------------------------------------------------------*/
2741
2742 int C2F(convert2sci)(integer *ix)
2743 {
2744   integer ix1 = Top - Rhs + *ix;
2745   if (! C2F(mvfromto)(&ix1, ix)) return FALSE_;
2746   C2F(intersci).ntypes[*ix - 1] = '$';
2747   return TRUE_;
2748 }
2749
2750
2751
2752 /*-----------------------------------------------------------
2753  * strcpy_tws : fname[0:nlgh-2]=' '
2754  * fname[nlgh-1] = '\0'
2755  * then second string is copied into first one
2756  * ------------------------------------------------------------*/
2757
2758 void strcpy_tws(char *str1,char *str2, int len)
2759 {
2760   int i;
2761   for ( i =0 ; i  < (int)strlen(str2); i++ ) str1[i]=str2[i];
2762   for (i = (int)strlen(str2) ; i < len ; i++) str1[i]=' ';
2763   str1[len-1] ='\0';
2764 }
2765
2766 /*---------------------------------------------------------------------
2767  *     conversion from Scilab code --> ascii
2768  *     + add a 0 at end of string
2769  *---------------------------------------------------------------------*/
2770
2771 int C2F(in2str)(integer *n,integer *line,char *str,unsigned long str_len)
2772 {
2773   C2F(codetoascii)(n,line, str, str_len);
2774   str[*n] = '\0';
2775   return 0;
2776 }
2777
2778 /*---------------------------------------------------------------------
2779  * Get_Iname:
2780  * Get the name (interfcae name) which was stored in ids while in checkrhs
2781  *---------------------------------------------------------------------*/
2782
2783 static char Fname[nlgh+1];
2784
2785 static char *Get_Iname()
2786 {
2787   int i;
2788   C2F(cvname)(&C2F(recu).ids[(C2F(recu).pt + 1) * nsiz - nsiz], Fname, &cx1, nlgh);
2789   /** remove trailing blanks **/
2790   for (i=0 ; i < nlgh ; i++) if (Fname[i]==' ') { Fname[i]='\0'; break;}
2791   Fname[nlgh]='\0';
2792   return Fname;
2793 }
2794
2795
2796 /*---------------------------------------------------------------------
2797  * Utility for error message
2798  *---------------------------------------------------------------------*/
2799
2800 static char *pos[] ={"first","second","third","fourth"};
2801 static char arg_position[56]; /* @TODO WTF is 56 ? */
2802
2803 char *ArgPosition(int i)
2804 {
2805   if ( i > 0 && i <= 4 )
2806     sprintf(arg_position,_("%s argument"),pos[i-1]);
2807   else
2808     sprintf(arg_position,_("argument number %d"),i);
2809   return arg_position;
2810 }
2811
2812 char *ArgsPosition(int i,int j)
2813 {
2814   if ( i > 0 && i <= 4 )
2815     {
2816       if ( j > 0 && j <= 4 )
2817         sprintf(arg_position,_("%s and %s arguments"),pos[i-1],pos[j-1]);
2818       else
2819         sprintf(arg_position,_("%s argument and argument %d"),pos[i-1],j);
2820     }
2821   else
2822     {
2823       if ( j > 0 && j <= 4 )
2824         sprintf(arg_position,_("%s argument and argument %d"),pos[j-1],i);
2825       else
2826         sprintf(arg_position,_("arguments %d and %d"),i,j);
2827     }
2828   return arg_position;
2829 }
2830
2831
2832 /*---------------------------------------------------------------------
2833  * Utility for back convertion to Scilab format
2834  * (can be used with GetListRhsVar )
2835  *---------------------------------------------------------------------*/
2836
2837 static void ConvertData(unsigned char *type, int size,int l)
2838 {
2839   int zero=0,mu=-1; int laddr; int prov,m,n,it;
2840   double wsave;
2841   switch (type[0]) {
2842   case 'c' :
2843     C2F(cvstr1)(&size,(int *) cstk(l),cstk(l),&zero,size);
2844     break;
2845   case 'r'  :
2846     C2F(rea2db)(&size,sstk(l),&mu,(double *)sstk(l),&mu);
2847     break;
2848   case 'i' :
2849     C2F(int2db)(&size,istk(l),&mu,(double *)istk(l),&mu);
2850     break;
2851   case 'z' :
2852     if (*istk( iadr(iadr(l))-2 ) == 133 ){  /* values @ even adress */
2853       prov=*istk( iadr(iadr(l))-1 );
2854       m=*istk(prov);n=*istk(prov+1);it=1;
2855       laddr=iadr(l);       wsave=*stk(laddr);
2856       /* make header */
2857       *istk( iadr(iadr(l))-2 ) = 1;
2858       *istk( iadr(iadr(l))-1 ) = m;
2859       *istk( iadr(iadr(l)) ) = n;
2860       *istk( iadr(iadr(l))+1 ) = it;
2861       /* convert values */
2862       z2double(stk(laddr),stk(laddr+1),m*n, m*n);
2863       *stk(laddr+1)=wsave;
2864     } else
2865       {
2866         F77ToSci((double *) zstk(l), size, size);
2867       }
2868   }
2869 }
2870
2871 /*---------------------------------------------------------------------
2872  * Utility for checking properties
2873  *---------------------------------------------------------------------*/
2874
2875 static int check_prop(char *mes,int posi,int m)
2876 {
2877   if ( m )
2878     {
2879       /* XXXX moduler 999 en fn des messages */
2880       Scierror(999,"%s: %s %s\n",Get_Iname(), ArgPosition(posi), mes);
2881       return FALSE_;
2882     }
2883   return TRUE_;
2884 }
2885
2886 int check_square (int posi,int m,int n)
2887 {
2888   return check_prop(_("should be square"),posi, m != n);
2889 }
2890
2891 int check_vector (int posi,int m,int n)
2892 {
2893   return check_prop(_("should be a vector"),posi, m != 1 && n != 1);
2894 }
2895
2896 int check_row (int posi,int m,int n)
2897 {
2898   return check_prop(_("should be a row vector"),posi, m != 1);
2899 }
2900
2901 int check_col (int posi,int m,int n)
2902 {
2903   return check_prop(_("should be a column vector"),posi, n != 1);
2904 }
2905
2906 int check_scalar (int posi,int m,int n)
2907 {
2908   return check_prop(_("should be a scalar"),posi, n != 1 || m != 1);
2909 }
2910
2911 int check_dims(int posi,int m,int n,int m1,int n1)
2912 {
2913   if ( m != m1 ||  n != n1 )
2914     {
2915       Scierror(999,_("%s : %s has wrong dimensions (%d,%d), expecting (%d,%d).\n"),Get_Iname(),ArgPosition(posi),m,n,m1,n1);
2916       return FALSE_;
2917     }
2918   return TRUE_;
2919 }
2920
2921 int check_one_dim(int posi,int dim,int val,int valref)
2922 {
2923   if ( val != valref)
2924     {
2925       Scierror(999,_("%s : %s has wrong %s dimension (%d), expecting (%d).\n"), Get_Iname(), ArgPosition(posi),  ( dim == 1 ) ? _("first") : _("second") , val,valref);
2926       return FALSE_;
2927     }
2928   return TRUE_;
2929 }
2930
2931 int check_length(int posi,int m,int m1)
2932 {
2933   if ( m != m1 )
2934     {
2935       Scierror(999,_("%s : %s has wrong length %d, expecting (%d).\n"), Get_Iname(), ArgPosition(posi), m, m1);
2936       return FALSE_;
2937     }
2938   return TRUE_;
2939 }
2940
2941 int check_same_dims(int i,int j,int m1,int n1,int m2,int n2)
2942 {
2943   if ( m1 == m2 && n1 == n2 ) return TRUE_ ;
2944   Scierror(999,_("%s : %s have incompatible dimensions (%dx%d) # (%dx%d)\n"),Get_Iname(), ArgsPosition(i,j),  m1,n1,m2,n2);
2945   return FALSE_;
2946 }
2947
2948 int check_dim_prop(int i,int j,int flag)
2949 {
2950   if ( flag )
2951     {
2952       Scierror(999,_("%s : %s have incompatible dimensions.\n"), Get_Iname(), ArgsPosition(i,j));
2953       return FALSE_;
2954     }
2955   return TRUE_;
2956 }
2957
2958
2959 static int check_list_prop(char *mes, int lpos,int posi, int m)
2960 {
2961   if ( m )
2962     {
2963       Scierror(999,_("%s : %s should be a list with %d-element being %s.\n"), Get_Iname(), ArgPosition(posi),posi,mes);
2964       return FALSE_;
2965     }
2966   return TRUE_;
2967 }
2968
2969 int check_list_square __PARAMS((int lpos,int posi,int m,int n))
2970 {
2971   return check_list_prop(_("square"),lpos,posi, (m != n));
2972 }
2973
2974 int check_list_vector (int lpos,int posi,int m,int n)
2975 {
2976   return check_list_prop(_("a vector"),lpos,posi, m != 1 && n != 1);
2977 }
2978
2979 int check_list_row (int lpos,int posi,int m,int n)
2980 {
2981   return check_list_prop(_("a row vector"),lpos,posi, m != 1);
2982 }
2983
2984 int check_list_col (int lpos,int posi,int m,int n)
2985 {
2986   return check_list_prop(_("a column vector"),lpos,posi, n != 1);
2987 }
2988
2989 int check_list_scalar (int lpos,int posi,int m,int n)
2990 {
2991   return check_list_prop(_("a scalar"),lpos, posi, n != 1 || m != 1);
2992 }
2993
2994 int check_list_one_dim(int lpos,int posi,int dim,int val,int valref)
2995 {
2996   if ( val != valref)
2997     {
2998       Scierror(999,_("%s : argument %d(%d) has wrong %s dimension (%d), expecting (%d).\n"),Get_Iname(),lpos,posi,( dim == 1 ) ? _("first") : _("second") , val,valref);
2999       return FALSE_;
3000     }
3001   return TRUE_;
3002 }
3003
3004
3005
3006 /*---------------------------------------------------------------------
3007  * Utility for hand writen data extraction or creation
3008  *---------------------------------------------------------------------*/
3009
3010 int C2F(createdata)(integer *lw, integer n)
3011 {
3012   integer lw1;
3013   char *fname = Get_Iname();
3014   if (*lw > intersiz) {
3015     Scierror(999,_("%s : (%s) too many arguments in the stack edit stack.h and enlarge intersiz.\n"),fname,"createdata");
3016     return FALSE_ ;
3017   }
3018   Nbvars = Max(*lw,Nbvars);
3019   lw1 = *lw + Top - Rhs;
3020   if (*lw < 0) {
3021     Scierror(999,_("%s : bad call to %s! (1rst argument).\n"),fname,"createdata");
3022     return FALSE_ ;
3023   }
3024   if (! C2F(credata)(fname, &lw1, n, nlgh))    return FALSE_;
3025   C2F(intersci).ntypes[*lw - 1] = '$';
3026   C2F(intersci).iwhere[*lw - 1] = *Lstk(lw1);
3027   C2F(intersci).lad[*lw - 1] = *Lstk(lw1);
3028   return TRUE_;
3029 }
3030
3031 /*---------------------------------------------------------------------
3032  * copyvarfromsciptr
3033  *     copy a Scilab variable given by
3034  *      - its first adress l in stk
3035  *      - its size n
3036  *    to the variable position  lw
3037  *----------------------------------------------------------------------*/
3038 int C2F(copyvarfromsciptr)(integer lw, integer n,integer l)
3039 {
3040   int ret,un=1;
3041   if ((ret=C2F(createdata)(&lw, n))==FALSE_) return ret;
3042   C2F(unsfdcopy)(&n,stk(l),&un,stk(*Lstk(lw + Top - Rhs)),&un);
3043   return TRUE_;
3044 }
3045
3046 void *GetData(int lw)
3047      /* Usage: header = (int *) GetData(lw); header[0] = type of variable lw etc */
3048 {
3049   int lw1 = lw + Top - Rhs ;
3050   int l1 = *Lstk(lw1);
3051   int *loci = (int *) stk(l1);
3052   if (loci[0] < 0)
3053     {
3054       l1 = loci[1];
3055       loci = (int *) stk(l1);
3056     }
3057   C2F(intersci).ntypes[lw - 1] = '$';
3058   C2F(intersci).iwhere[lw - 1] = l1;
3059   C2F(intersci).lad[lw - 1] = l1;
3060   return loci;
3061 }
3062
3063 int GetDataSize(int lw)
3064      /* get memory used by the argument lw in double world etc */
3065 {
3066   int lw1 = lw + Top - Rhs ;
3067   int l1 = *Lstk(lw1);
3068   int *loci = (int *) stk(l1);
3069   int n =  *Lstk(lw1+1)-*Lstk(lw1);
3070   if (loci[0] < 0)
3071     {
3072       l1 = loci[1];
3073       loci = (int *) stk(l1);
3074       n=loci[3];
3075     }
3076   return n;
3077 }
3078
3079 void *GetRawData(int lw)
3080      /* same as GetData BUT does not go to the pointed variable if lw is a reference */
3081 {
3082   int lw1 = lw + Top - Rhs ;
3083   int l1 = *Lstk(lw1);
3084   int *loci = (int *) stk(l1);
3085   C2F(intersci).ntypes[lw - 1] = '$';
3086   C2F(intersci).iwhere[lw - 1] = l1;
3087   /*  C2F(intersci).lad[lw - 1] = l1;  to be checked */
3088   return loci;
3089 }
3090
3091 void *GetDataFromName( char *name )
3092      /* usage:  header = (int *) GetDataFromName("pipo"); header[0] = type of variable pipo etc... */
3093 {
3094   void *header; int lw; int fin;
3095  if (C2F(objptr)(name,&lw,&fin,(unsigned long)strlen(name))) {
3096     header = istk( iadr(*Lstk(fin)));
3097     return (void *) header;
3098   }
3099  else
3100     {
3101       Scierror(999,_("GetDataFromName: variable %s not found.\n"),name);
3102       return (void *) 0;
3103     }
3104 }
3105
3106 int C2F(createreference)(int number, int pointed)
3107 /* variable number is created as a reference to variable pointed */
3108 {
3109   int offset; int point_ed; int *header;
3110   CreateData( number, 4*sizeof(int) );
3111   header =  GetRawData(number);
3112   offset = Top -Rhs;
3113   point_ed = offset + pointed;
3114   header[0]= - *istk( iadr(*Lstk( point_ed )) );  /* reference : 1st entry (type) is opposite */
3115   header[1]= *Lstk(point_ed);  /* pointed adress */
3116   header[2]= point_ed; /* pointed variable */
3117   header[3]= *Lstk(point_ed + 1)- *Lstk(point_ed);  /* size of pointed variable */
3118   C2F(intersci).ntypes[number-1]= '-';
3119   return 1;
3120 }
3121
3122 int C2F(changetoref)(int number, int pointed)
3123 /* variable number is changed as a reference to variable pointed */
3124 {
3125   int offset; int point_ed; int *header;
3126   header =  GetRawData(number);
3127   offset = Top - Rhs;
3128   point_ed = offset + pointed;
3129   header[0]= - *istk( iadr(*Lstk( point_ed )) );  /* reference : 1st entry (type) is opposite */
3130   header[1]= *Lstk(point_ed);  /* pointed adress */
3131   header[2]= pointed; /* pointed variable */
3132   header[3]= *Lstk(point_ed + 1) - *Lstk(point_ed);  /* size of pointed variable */
3133   C2F(intersci).ntypes[number-1]= '-';
3134   return 1;
3135 }
3136
3137 int C2F(createreffromname)(int number, char *name)
3138      /* variable number is created as a reference pointing to variable "name" */
3139      /* name must be an existing Scilab variable */
3140 {
3141   int *header; int lw; int fin;
3142   CreateData(number, 4*sizeof(int));
3143   header = (int *) GetData(number);
3144   if (C2F(objptr)(name,&lw,&fin,(unsigned long)strlen(name))) {
3145     header[0]= - *istk( iadr(*Lstk(fin))); /* type of reference = - type of pointed variable */
3146     header[1]= lw; /* pointed adress */
3147     header[2]= fin; /* pointed variable */
3148     header[3]= *Lstk(fin+1)- *Lstk(fin);  /*size of pointed variable */
3149     return 1;
3150   }
3151   else
3152     {
3153       Scierror(999,_("CreateRefFromName: variable %s not found.\n"),name);
3154       return 0;
3155     }
3156 }
3157
3158 /*-------------------------------------------------------
3159  * protect the intersci common during recursive calls
3160  *-------------------------------------------------------*/
3161
3162 typedef struct inter_s_ {
3163   int iwhere,nbrows,nbcols,itflag,ntypes,lad,ladc,lhsvar;
3164 } intersci_state ;
3165
3166 typedef struct inter_l {
3167   intersci_state *state ;
3168   int nbvars;
3169   struct inter_l * next ;
3170 } intersci_list ;
3171
3172 static intersci_list * L_intersci;
3173
3174
3175 static int intersci_push(void)
3176 {
3177   int i;
3178   intersci_list *loc;
3179   intersci_state *new ;
3180   new = MALLOC( Nbvars * sizeof(intersci_state) );
3181   if (new == 0 ) return 0;
3182   loc = MALLOC( sizeof(intersci_list) );
3183   if ( loc == NULL ) return 0;
3184   loc->next = L_intersci;
3185   loc->state = new;
3186   loc->nbvars =  Nbvars;
3187   for ( i = 0 ; i <  Nbvars ; i++ )
3188     {
3189       loc->state[i].iwhere = C2F(intersci).iwhere[i];
3190       loc->state[i].ntypes = C2F(intersci).ntypes[i];
3191       loc->state[i].lad    = C2F(intersci).lad[i];
3192       loc->state[i].lhsvar = C2F(intersci).lhsvar[i];
3193     }
3194   L_intersci = loc;
3195   return 1;
3196 }
3197
3198 static void intersci_pop(void)
3199 {
3200   int i;
3201   intersci_list *loc = L_intersci;
3202   if ( loc == NULL ) return ;
3203   Nbvars =  loc->nbvars;
3204   for ( i = 0 ; i <  Nbvars ; i++ )
3205     {
3206       C2F(intersci).iwhere[i] =   loc->state[i].iwhere ;
3207       C2F(intersci).ntypes[i] =   loc->state[i].ntypes ;
3208       C2F(intersci).lad[i] =   loc->state[i].lad    ;
3209       C2F(intersci).lhsvar[i] =   loc->state[i].lhsvar ;
3210     }
3211   L_intersci = loc->next ;
3212   FREE(loc->state);
3213   FREE(loc);
3214 }
3215
3216 /*
3217 static void intersci_show()
3218 {
3219   int i;
3220   fprintf(stderr,"======================\n");
3221   for ( i = 0 ; i < C2F(intersci).nbvars ; i++ )
3222     {
3223       fprintf(stderr,"%d %d %d\n",i,
3224               C2F(intersci).iwhere[i],
3225               C2F(intersci).ntypes[i]);
3226     }
3227   fprintf(stderr,"======================\n");
3228 }
3229
3230 */
3231