summaryrefslogtreecommitdiffstats
path: root/scilab/modules/symbolic/sci_gateway
diff options
context:
space:
mode:
authorAllan Cornet <allan.cornet@scilab.org>2006-08-08 09:49:24 +0000
committerAllan Cornet <allan.cornet@scilab.org>2006-08-08 09:49:24 +0000
commit7475aa5cdc345de30ed7421eea947ce91049ccba (patch)
tree00990eb0e66975c2ca89eecde7bc21a65c517141 /scilab/modules/symbolic/sci_gateway
parentd142444c45fe52ab80593780d8ddf5baede70fbc (diff)
downloadscilab-7475aa5cdc345de30ed7421eea947ce91049ccba.zip
scilab-7475aa5cdc345de30ed7421eea947ce91049ccba.tar.gz
Reorganization
symbolic module move files to do : rename fmlelm.fundef --> symbolic.fundef add macros help et project
Diffstat (limited to 'scilab/modules/symbolic/sci_gateway')
-rw-r--r--scilab/modules/symbolic/sci_gateway/c/gw_symbolic.c55
-rw-r--r--scilab/modules/symbolic/sci_gateway/c/sci_addsubf.c21
-rw-r--r--scilab/modules/symbolic/sci_gateway/c/sci_ldivf.c15
-rw-r--r--scilab/modules/symbolic/sci_gateway/c/sci_mulf.c15
-rw-r--r--scilab/modules/symbolic/sci_gateway/c/sci_rdivf.c15
-rw-r--r--scilab/modules/symbolic/sci_gateway/fmlelm.fundef6
-rw-r--r--scilab/modules/symbolic/sci_gateway/fortran/sci_addsubf.f166
-rw-r--r--scilab/modules/symbolic/sci_gateway/fortran/sci_ldivf.f261
-rw-r--r--scilab/modules/symbolic/sci_gateway/fortran/sci_mulf.f262
-rw-r--r--scilab/modules/symbolic/sci_gateway/fortran/sci_rdivf.f261
10 files changed, 1077 insertions, 0 deletions
diff --git a/scilab/modules/symbolic/sci_gateway/c/gw_symbolic.c b/scilab/modules/symbolic/sci_gateway/c/gw_symbolic.c
new file mode 100644
index 0000000..ba3445f
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/c/gw_symbolic.c
@@ -0,0 +1,55 @@
1#include "gw_symbolic.h"
2/*-----------------------------------------------------------------------------------*/
3/* INRIA 2006 */
4/* Allan CORNET */
5/*-----------------------------------------------------------------------------------*/
6#if _MSC_VER
7#include <Windows.h>
8#include "MALLOC.h"
9extern char *GetExceptionString(DWORD ExceptionCode);
10#endif
11/*-----------------------------------------------------------------------------------*/
12
13extern int C2F(sci_addf) _PARAMS((char *fname,unsigned long fname_len));
14extern int C2F(sci_subf) _PARAMS((char *fname,unsigned long fname_len));
15extern int C2F(sci_mulf) _PARAMS((char *fname,unsigned long fname_len));
16extern int C2F(sci_ldivf) _PARAMS((char *fname,unsigned long fname_len));
17extern int C2F(sci_rdivf) _PARAMS((char *fname,unsigned long fname_len));
18/*-----------------------------------------------------------------------------------*/
19static SymbolicTable Tab[]=
20{
21{C2F(sci_addf),"addf"},
22{C2F(sci_subf),"subf"},
23{C2F(sci_mulf),"mulf"},
24{C2F(sci_ldivf),"ldivf"},
25{C2F(sci_rdivf),"rdivf"}
26};
27/*-----------------------------------------------------------------------------------*/
28int C2F(gw_symbolic)()
29{
30 if (Rhs != 2)
31 {
32 Scierror(39,"incorrect number of arguments.\r\n");
33 return 0;
34 }
35#if _MSC_VER
36 #ifndef _DEBUG
37 _try
38 {
39 (*(Tab[Fin-1].f)) (Tab[Fin-1].name,strlen(Tab[Fin-1].name));
40 }
41 _except (EXCEPTION_EXECUTE_HANDLER)
42 {
43 char *ExceptionString=GetExceptionString(GetExceptionCode());
44 sciprint("Warning !!!\nScilab has found a critical error (%s)\nwith \"%s\" function.\nScilab may become unstable.\n",ExceptionString,Tab[Fin-1].name);
45 if (ExceptionString) {FREE(ExceptionString);ExceptionString=NULL;}
46 }
47 #else
48 (*(Tab[Fin-1].f)) (Tab[Fin-1].name,strlen(Tab[Fin-1].name));
49 #endif
50#else
51 (*(Tab[Fin-1].f)) (Tab[Fin-1].name,strlen(Tab[Fin-1].name));
52#endif
53 return 0;
54}
55/*-----------------------------------------------------------------------------------*/
diff --git a/scilab/modules/symbolic/sci_gateway/c/sci_addsubf.c b/scilab/modules/symbolic/sci_gateway/c/sci_addsubf.c
new file mode 100644
index 0000000..4ca1ad0
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/c/sci_addsubf.c
@@ -0,0 +1,21 @@
1/*-----------------------------------------------------------------------------------*/
2/* INRIA 2006 */
3/* Allan CORNET */
4/*-----------------------------------------------------------------------------------*/
5#include "../machine.h"
6#include "../stack-c.h"
7/*-----------------------------------------------------------------------------------*/
8extern int C2F(sciaddfsubf) _PARAMS((char *fname));
9/*-----------------------------------------------------------------------------------*/
10int C2F(sci_addf) _PARAMS((char *fname,unsigned long fname_len))
11{
12 C2F(sciaddfsubf)(fname);
13 return 0;
14}
15/*-----------------------------------------------------------------------------------*/
16int C2F(sci_subf) _PARAMS((char *fname,unsigned long fname_len))
17{
18 C2F(sciaddfsubf)(fname);
19 return 0;
20}
21/*-----------------------------------------------------------------------------------*/
diff --git a/scilab/modules/symbolic/sci_gateway/c/sci_ldivf.c b/scilab/modules/symbolic/sci_gateway/c/sci_ldivf.c
new file mode 100644
index 0000000..b8dc2f9
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/c/sci_ldivf.c
@@ -0,0 +1,15 @@
1/*-----------------------------------------------------------------------------------*/
2/* INRIA 2006 */
3/* Allan CORNET */
4/*-----------------------------------------------------------------------------------*/
5#include "../machine.h"
6#include "../stack-c.h"
7/*-----------------------------------------------------------------------------------*/
8extern int C2F(scildivf) _PARAMS((char *fname));
9/*-----------------------------------------------------------------------------------*/
10int C2F(sci_ldivf) _PARAMS((char *fname,unsigned long fname_len))
11{
12 C2F(scildivf)(fname);
13 return 0;
14}
15/*-----------------------------------------------------------------------------------*/
diff --git a/scilab/modules/symbolic/sci_gateway/c/sci_mulf.c b/scilab/modules/symbolic/sci_gateway/c/sci_mulf.c
new file mode 100644
index 0000000..66e5996
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/c/sci_mulf.c
@@ -0,0 +1,15 @@
1/*-----------------------------------------------------------------------------------*/
2/* INRIA 2006 */
3/* Allan CORNET */
4/*-----------------------------------------------------------------------------------*/
5#include "../machine.h"
6#include "../stack-c.h"
7/*-----------------------------------------------------------------------------------*/
8extern int C2F(scimulf) _PARAMS((char *fname));
9/*-----------------------------------------------------------------------------------*/
10int C2F(sci_mulf) _PARAMS((char *fname,unsigned long fname_len))
11{
12 C2F(scimulf)(fname);
13 return 0;
14}
15/*-----------------------------------------------------------------------------------*/
diff --git a/scilab/modules/symbolic/sci_gateway/c/sci_rdivf.c b/scilab/modules/symbolic/sci_gateway/c/sci_rdivf.c
new file mode 100644
index 0000000..ed38840
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/c/sci_rdivf.c
@@ -0,0 +1,15 @@
1/*-----------------------------------------------------------------------------------*/
2/* INRIA 2006 */
3/* Allan CORNET */
4/*-----------------------------------------------------------------------------------*/
5#include "../machine.h"
6#include "../stack-c.h"
7/*-----------------------------------------------------------------------------------*/
8extern int C2F(scirdivf) _PARAMS((char *fname));
9/*-----------------------------------------------------------------------------------*/
10int C2F(sci_rdivf) _PARAMS((char *fname,unsigned long fname_len))
11{
12 C2F(scirdivf)(fname);
13 return 0;
14}
15/*-----------------------------------------------------------------------------------*/
diff --git a/scilab/modules/symbolic/sci_gateway/fmlelm.fundef b/scilab/modules/symbolic/sci_gateway/fmlelm.fundef
new file mode 100644
index 0000000..3a47210
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/fmlelm.fundef
@@ -0,0 +1,6 @@
1{"addf", IN_fmlelm, 1, 0},
2{"subf", IN_fmlelm, 2, 0},
3{"mulf", IN_fmlelm, 3, 0},
4{"ldivf", IN_fmlelm, 4, 2},
5{"rdivf", IN_fmlelm, 5, 0},
6
diff --git a/scilab/modules/symbolic/sci_gateway/fortran/sci_addsubf.f b/scilab/modules/symbolic/sci_gateway/fortran/sci_addsubf.f
new file mode 100644
index 0000000..7c54c49
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/fortran/sci_addsubf.f
@@ -0,0 +1,166 @@
1c --------------------------
2c Copyright INRIA
3c --------------------------
4c
5 subroutine sciaddfsubf(fname)
6c ----------------------------
7 character*(*) fname
8 include '../stack.h'
9
10 logical iseye,isnum
11 integer lparen,rparen,star,plus,minus,blanc,slash,bslash,symb
12 integer iadr,sadr
13 data lparen/41/,rparen/42/,star/47/,plus/45/,minus/46/,blanc/40/
14 data slash/48/ ,bslash/49/
15
16 iadr(l)=l+l-1
17 sadr(l)=(l/2)+1
18
19 isg=1
20 if(fin.eq.2) isg=-1
21 ilptr1=iadr(lstk(top+1))+1
22c le "+1" est du a expsum qui peut renvoyer une chaine 1 carac plus long
23c que la chaine donnee
24 il1=iadr(lstk(top-1))
25 il=il1
26 if(istk(il1).ne.10) then
27 err=1
28 call error(55)
29 return
30 endif
31 il2=iadr(lstk(top))
32 if(istk(il2).ne.10) then
33 err=2
34 call error(55)
35 return
36 endif
37 is=plus
38c
39 if(istk(il1+1)*istk(il1+2).ne.1) then
40 err=1
41 call error(36)
42 return
43 endif
44 n1=istk(il1+5)-1
45 il1=il1+6
46 il0=il1
47 maxnp=iadr(lstk(bot))-ilptr1
48 call expsum(1,istk(il1),n1,istk(ilptr1),np1,maxnp,err)
49 if(err.gt.0) then
50 call error(17)
51 return
52 endif
53c
54 ilptr2=ilptr1+np1+1
55 if(istk(il2+1)*istk(il2+2).ne.1) then
56 err=2
57 call error(36)
58 return
59 endif
60 n2=istk(il2+5)-1
61 il2=il2+6
62 top=top-1
63 maxnp=iadr(lstk(bot))-ilptr2
64 call expsum(isg,istk(il2),n2,istk(ilptr2),np2,maxnp,err)
65 if(err.gt.0) then
66 call error(17)
67 return
68 endif
69c
70 inum=0
71 do 1005 i1=1,np1
72 it1=il1-1+istk(ilptr1-1+i1)
73 nt1=istk(ilptr1+i1)-istk(ilptr1-1+i1)
74 if(istk(it1+1).eq.0.and.n1.eq.2) then
75 call icopy(n2,istk(il2),1,istk(il1),1)
76 il1=il1+n2
77 goto 1010
78 endif
79 if(isnum(istk(it1+1),nt1-1,inum1)) then
80 if(istk(it1).eq.minus) inum1=-inum1
81 inum=inum+inum1
82 istk(it1)=0
83 endif
84 i2=0
85 1004 i2=i2+1
86 if(i2.gt.np2) goto 1005
87 it2=il2-1+istk(ilptr2-1+i2)
88 if(istk(it2).eq.0) goto 1004
89 nt2=istk(ilptr2+i2)-istk(ilptr2-1+i2)
90 if(istk(it2+1).eq.0.and.n2.eq.2) then
91 if (istk(it1).ne.0) then
92 il1=il1+n1
93 goto 1010
94 else
95 ilw=il1
96 goto 1008
97 endif
98 endif
99 if(isnum(istk(it2+1),nt2-1,inum2)) then
100 if(istk(it2).eq.minus) inum2=-inum2
101 inum=inum+inum2
102 istk(it2)=0
103 goto 1004
104 endif
105 if (istk(it1).ne.istk(it2).and.nt1.eq.nt2) then
106c on regarde si les termes sont egaux
107 do 1002 k=2,nt1
108 if(istk(it1-1+k).ne.istk(it2-1+k)) goto 1004
109 1002 continue
110 istk(it2)=0
111 istk(it1)=0
112 goto 1005
113 endif
114 goto 1004
115 1005 continue
116c
117 ilw=il1
118 do 1006 i1=1,np1
119 it1=il1-1+istk(ilptr1-1+i1)
120 nt1=istk(ilptr1+i1)-istk(ilptr1-1+i1)
121 if(istk(it1).ne.0) then
122 call icopy(nt1,istk(it1),1,istk(ilw),1)
123 ilw=ilw+nt1
124 endif
125 1006 continue
126 do 1007 i2=1,np2
127 it2=il2-1+istk(ilptr2-1+i2)
128 nt2=istk(ilptr2+i2)-istk(ilptr2-1+i2)
129 if(istk(it2).ne.0) then
130 call icopy(nt2,istk(it2),1,istk(ilw),1)
131 ilw=ilw+nt2
132 endif
133 1007 continue
134c
135 1008 if(inum.ne.0) then
136 if(inum.lt.0) then
137 istk(ilw)=minus
138 ilw=ilw+1
139 inum=-inum
140 elseif(ilw.ne.il0) then
141 istk(ilw)=plus
142 ilw=ilw+1
143 endif
144 call intstr(inum,istk(ilw),ni,0)
145 ilw=ilw+ni
146 endif
147c
148 il1=ilw
149 if(il1.eq.il0) then
150 istk(il1)=0
151 il1=il1+1
152 endif
153c
154 1010 n1=il1-il0
155 if(istk(il0).eq.plus) then
156 call icopy(n1-1,istk(il0+1),1,istk(il0),1)
157 n1=n1-1
158 il1=il1-1
159 endif
160 istk(il+5)=n1+1
161 lstk(top+1)=sadr(il1+1)
162 goto 9999
163
164 9999 return
165 end
166 \ No newline at end of file
diff --git a/scilab/modules/symbolic/sci_gateway/fortran/sci_ldivf.f b/scilab/modules/symbolic/sci_gateway/fortran/sci_ldivf.f
new file mode 100644
index 0000000..450b75d
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/fortran/sci_ldivf.f
@@ -0,0 +1,261 @@
1c --------------------------
2c Copyright INRIA
3c --------------------------
4c
5 subroutine scildivf(fname)
6c ----------------------------
7 character*(*) fname
8 include '../stack.h'
9
10 logical iseye,isnum
11 integer lparen,rparen,star,plus,minus,blanc,slash,bslash,symb
12 integer iadr,sadr
13 data lparen/41/,rparen/42/,star/47/,plus/45/,minus/46/,blanc/40/
14 data slash/48/ ,bslash/49/
15
16 iadr(l)=l+l-1
17 sadr(l)=(l/2)+1
18
19 symb=bslash
20
21 il1=iadr(lstk(top-1))
22 il=il1
23 if(istk(il1).ne.10) then
24 err=1
25 call error(55)
26 return
27 endif
28 if(istk(il1+1)*istk(il1+2).ne.1) then
29 err=1
30 call error(36)
31 return
32 endif
33 n1=istk(il1+5)-1
34 il1=il1+6
35 il0=il1
36 call atome(istk(il1),n1,it1,is1)
37 if(symb.ne.bslash) call termf(istk(il1),n1,it1)
38c
39 il2=iadr(lstk(top))
40 if(istk(il2).ne.10) then
41 err=2
42 call error(55)
43 return
44 endif
45 if(istk(il2+1)*istk(il2+2).ne.1) then
46 err=2
47 call error(36)
48 return
49 endif
50 n2=istk(il2+5)-1
51 il2=il2+6
52 top=top-1
53c
54 call atome(istk(il2),n2,it2,is2)
55 if(symb.ne.slash) call termf(istk(il2),n2,it2)
56 if (it2.ne.0) call factf(istk(il2),n2,it2)
57
58c
59 goto (2010,2020,2030,2040) it1+2*it2+1
60c
61c 2 expressions
62 2010 continue
63 idec=0
64 if(is1.ne.1) then
65 call icopy(n1,istk(il1),-1,istk(il1+1),-1)
66 idec=1
67 endif
68 il0=il1
69 istk(il1)=lparen
70 istk(il1+n1+idec)=rparen
71 il1=il1+n1+idec+1
72 istk(il1)=symb
73 il1=il1+1
74 istk(il1)=lparen
75 il1=il1+1
76 if(is2.eq.1) then
77 il2=il2+1
78 n2=n2-1
79 endif
80 call icopy(n2,istk(il2),1,istk(il1),1)
81 il1=il1+n2
82 istk(il1)=rparen
83 il1=il1+1
84 istk(il+5)=il1-il0+1
85 lstk(top+1)=sadr(il1)
86 goto 9999
87 2020 continue
88c un atome et une expression
89 idec=abs(is1)
90 ipar=0
91 if(n1-idec.eq.1 .and.istk(il1+idec).eq.0) then
92 if(symb.eq.bslash) then
93 call error(27)
94 return
95 endif
96 goto 9999
97 endif
98 if(symb.ne.slash.and.
99 & ((n1-idec.eq.1 .and. istk(il1+idec).eq.1).or.
100 & (n1-idec.eq.5.and.iseye(istk(il1+idec))))) then
101c n1=n1-1
102 n1=idec
103 if(is1.eq.-1) then
104 istk(il1+n1)=lparen
105 n1=n1+1
106 ipar=1
107 endif
108 goto 2021
109 else
110 istk(il1+n1)=symb
111 istk(il1+n1+1)=lparen
112 n1=n1+2
113 ipar=1
114 endif
115 2021 if(is2.eq.1) then
116 il2=il2+1
117 n2=n2-1
118 endif
119 call icopy(n2,istk(il2),1,istk(il1+n1),1)
120 n1=n1+n2
121 if(ipar.eq.1) then
122 istk(il1+n1)=rparen
123 n1=n1+1
124 endif
125 istk(il+5)=1+n1
126 lstk(top+1)=sadr(il1+n1)
127 goto 9999
128c expr et atome
129 2030 continue
130 idec=abs(is2)
131 if(n2-idec.eq.1.and.istk(il2+idec).eq.0) then
132 if(symb.eq.slash) then
133 call error(27)
134 return
135 endif
136 istk(il1)=0
137 istk(il+5)=2
138 lstk(top+1)=sadr(il1+1)
139 goto 9999
140 endif
141 if(symb.ne.bslash.and.is2.ge.0
142 & .and.((n2-idec.eq.1.and.istk(il2+idec).eq.1)
143 & .or.(n2-idec.eq.5.and.iseye(istk(il2+idec))))) then
144 istk(il+5)=n1+1
145 lstk(top+1)=sadr(il1+n1)
146 goto 9999
147 endif
148 idec=0
149 if(is1.ne.1) idec=idec+1
150 if(is2.lt.0) idec=idec+1
151 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
152 il0=il1
153 ill=il1
154 if(is2.lt.0) then
155 istk(ill)=minus
156 ill=ill+1
157 endif
158 istk(ill)=lparen
159 istk(il1+n1+idec)=rparen
160 il1=il1+n1+idec+1
161 if(symb.ne.bslash.and.is2.eq.-1.and.
162 & ((n2.eq.2.and.istk(il2+1).eq.1).or.
163 & (n2.eq.6.and.iseye(istk(il2+1))))) goto 2031
164 istk(il1)=symb
165 il1=il1+1
166 if(is2.ne.0) then
167 il2=il2+1
168 n2=n2-1
169 endif
170 call icopy(n2,istk(il2),1,istk(il1),1)
171 il1=il1+n2
172 2031 istk(il+5)=il1-il0+1
173 lstk(top+1)=sadr(il1)
174 goto 9999
175c atome et atome
176 2040 continue
177
178 idec1=abs(is1)
179 if(n1-idec1.eq.1.and.istk(il1+idec1).eq.0) then
180 if(symb.eq.bslash) then
181 call error(27)
182 return
183 endif
184 goto 9999
185 endif
186 idec2=abs(is2)
187 if(n2-idec2.eq.1.and.istk(il2+idec2).eq.0) then
188 if(symb.eq.slash) then
189 call error(27)
190 return
191 endif
192 istk(il1)=0
193 istk(il+5)=2
194 lstk(top+1)=sadr(il1+1)
195 goto 9999
196 endif
197 if(symb.eq.star) then
198 if(isnum(istk(il1+idec1),n1-idec1,inum1).and.
199 & isnum(istk(il2+idec2),n2-idec2,inum2)) then
200 if(is1.eq.-1) inum1=-inum1
201 if(is2.eq.-1) inum2=-inum2
202 inum=inum1*inum2
203 call intstr(inum,istk(il1),ni,0)
204 il1=il1+ni
205 istk(il+5)=ni+1
206 lstk(top+1)=sadr(il1)
207 goto 9999
208 endif
209 endif
210 is=blanc
211 if(is1.eq.-1.and.is2.ge.0 .or.
212 + is2.eq.-1.and.is1.ge.0) is=minus
213 if(symb.ne.slash.and.
214 & ((n1-abs(is1).eq.1.and.istk(il1+abs(is1)).eq.1).or.
215 & (n1-abs(is1).eq.5.and.iseye(istk(il1+abs(is1))))) ) then
216 if(is.eq.minus) then
217 istk(il1)=is
218 il1=il1+1
219 endif
220 call icopy(n2-abs(is2),istk(il2+abs(is2)),1,istk(il1),1)
221 il1=il1+n2-abs(is2)
222 istk(il+5)=il1-il0+1
223 lstk(top+1)=sadr(il1+1)
224 goto 9999
225 endif
226 idec1=0
227 idec=0
228 if(is1.eq.-1.and.is2.eq.-1) idec1=1
229 if(is.eq.minus.and.is1.eq.0) then
230 idec=1
231 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
232 n1=n1+1
233 endif
234 if(idec1.ne.0) then
235 call icopy(n1-1,istk(il1+idec+1),1,istk(il1+idec),1)
236 n1=n1-1
237 endif
238 il0=il1
239 ill=il1
240 if(is.eq.minus) then
241 istk(ill)=minus
242 ill=ill+1
243 endif
244 il1=il1+n1
245 if(symb.ne.bslash.and.
246 & ((n2-abs(is2).eq.1.and.istk(il2+abs(is2)).eq.1).or.
247 & (n2-abs(is2).eq.5.and.iseye(istk(il2+abs(is2)))))) goto 2041
248 istk(il1)=symb
249 il1=il1+1
250 if(is2.ne.0) then
251 il2=il2+1
252 n2=n2-1
253 endif
254 call icopy(n2,istk(il2),1,istk(il1),1)
255 il1=il1+n2
256 2041 istk(il+5)=il1-il0+1
257 lstk(top+1)=sadr(il1)
258 goto 9999
259c
260 9999 return
261 end
diff --git a/scilab/modules/symbolic/sci_gateway/fortran/sci_mulf.f b/scilab/modules/symbolic/sci_gateway/fortran/sci_mulf.f
new file mode 100644
index 0000000..8adf367
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/fortran/sci_mulf.f
@@ -0,0 +1,262 @@
1c --------------------------
2c Copyright INRIA
3c --------------------------
4c
5 subroutine scimulf(fname)
6c ----------------------------
7 character*(*) fname
8 include '../stack.h'
9
10 logical iseye,isnum
11 integer lparen,rparen,star,plus,minus,blanc,slash,bslash,symb
12 integer iadr,sadr
13 data lparen/41/,rparen/42/,star/47/,plus/45/,minus/46/,blanc/40/
14 data slash/48/ ,bslash/49/
15
16 iadr(l)=l+l-1
17 sadr(l)=(l/2)+1
18
19 symb=star
20
21 il1=iadr(lstk(top-1))
22 il=il1
23 if(istk(il1).ne.10) then
24 err=1
25 call error(55)
26 return
27 endif
28 if(istk(il1+1)*istk(il1+2).ne.1) then
29 err=1
30 call error(36)
31 return
32 endif
33 n1=istk(il1+5)-1
34 il1=il1+6
35 il0=il1
36 call atome(istk(il1),n1,it1,is1)
37 if(symb.ne.bslash) call termf(istk(il1),n1,it1)
38c
39 il2=iadr(lstk(top))
40 if(istk(il2).ne.10) then
41 err=2
42 call error(55)
43 return
44 endif
45 if(istk(il2+1)*istk(il2+2).ne.1) then
46 err=2
47 call error(36)
48 return
49 endif
50 n2=istk(il2+5)-1
51 il2=il2+6
52 top=top-1
53c
54 call atome(istk(il2),n2,it2,is2)
55 if(symb.ne.slash) call termf(istk(il2),n2,it2)
56 if (it2.ne.0) call factf(istk(il2),n2,it2)
57
58c
59 goto (2010,2020,2030,2040) it1+2*it2+1
60c
61c 2 expressions
62 2010 continue
63 idec=0
64 if(is1.ne.1) then
65 call icopy(n1,istk(il1),-1,istk(il1+1),-1)
66 idec=1
67 endif
68 il0=il1
69 istk(il1)=lparen
70 istk(il1+n1+idec)=rparen
71 il1=il1+n1+idec+1
72 istk(il1)=symb
73 il1=il1+1
74 istk(il1)=lparen
75 il1=il1+1
76 if(is2.eq.1) then
77 il2=il2+1
78 n2=n2-1
79 endif
80 call icopy(n2,istk(il2),1,istk(il1),1)
81 il1=il1+n2
82 istk(il1)=rparen
83 il1=il1+1
84 istk(il+5)=il1-il0+1
85 lstk(top+1)=sadr(il1)
86 goto 9999
87 2020 continue
88c un atome et une expression
89 idec=abs(is1)
90 ipar=0
91 if(n1-idec.eq.1 .and.istk(il1+idec).eq.0) then
92 if(symb.eq.bslash) then
93 call error(27)
94 return
95 endif
96 goto 9999
97 endif
98 if(symb.ne.slash.and.
99 & ((n1-idec.eq.1 .and. istk(il1+idec).eq.1).or.
100 & (n1-idec.eq.5.and.iseye(istk(il1+idec))))) then
101c n1=n1-1
102 n1=idec
103 if(is1.eq.-1) then
104 istk(il1+n1)=lparen
105 n1=n1+1
106 ipar=1
107 endif
108 goto 2021
109 else
110 istk(il1+n1)=symb
111 istk(il1+n1+1)=lparen
112 n1=n1+2
113 ipar=1
114 endif
115 2021 if(is2.eq.1) then
116 il2=il2+1
117 n2=n2-1
118 endif
119 call icopy(n2,istk(il2),1,istk(il1+n1),1)
120 n1=n1+n2
121 if(ipar.eq.1) then
122 istk(il1+n1)=rparen
123 n1=n1+1
124 endif
125 istk(il+5)=1+n1
126 lstk(top+1)=sadr(il1+n1)
127 goto 9999
128c expr et atome
129 2030 continue
130 idec=abs(is2)
131 if(n2-idec.eq.1.and.istk(il2+idec).eq.0) then
132 if(symb.eq.slash) then
133 call error(27)
134 return
135 endif
136 istk(il1)=0
137 istk(il+5)=2
138 lstk(top+1)=sadr(il1+1)
139 goto 9999
140 endif
141 if(symb.ne.bslash.and.is2.ge.0
142 & .and.((n2-idec.eq.1.and.istk(il2+idec).eq.1)
143 & .or.(n2-idec.eq.5.and.iseye(istk(il2+idec))))) then
144 istk(il+5)=n1+1
145 lstk(top+1)=sadr(il1+n1)
146 goto 9999
147 endif
148 idec=0
149 if(is1.ne.1) idec=idec+1
150 if(is2.lt.0) idec=idec+1
151 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
152 il0=il1
153 ill=il1
154 if(is2.lt.0) then
155 istk(ill)=minus
156 ill=ill+1
157 endif
158 istk(ill)=lparen
159 istk(il1+n1+idec)=rparen
160 il1=il1+n1+idec+1
161 if(symb.ne.bslash.and.is2.eq.-1.and.
162 & ((n2.eq.2.and.istk(il2+1).eq.1).or.
163 & (n2.eq.6.and.iseye(istk(il2+1))))) goto 2031
164 istk(il1)=symb
165 il1=il1+1
166 if(is2.ne.0) then
167 il2=il2+1
168 n2=n2-1
169 endif
170 call icopy(n2,istk(il2),1,istk(il1),1)
171 il1=il1+n2
172 2031 istk(il+5)=il1-il0+1
173 lstk(top+1)=sadr(il1)
174 goto 9999
175c atome et atome
176 2040 continue
177
178 idec1=abs(is1)
179 if(n1-idec1.eq.1.and.istk(il1+idec1).eq.0) then
180 if(symb.eq.bslash) then
181 call error(27)
182 return
183 endif
184 goto 9999
185 endif
186 idec2=abs(is2)
187 if(n2-idec2.eq.1.and.istk(il2+idec2).eq.0) then
188 if(symb.eq.slash) then
189 call error(27)
190 return
191 endif
192 istk(il1)=0
193 istk(il+5)=2
194 lstk(top+1)=sadr(il1+1)
195 goto 9999
196 endif
197 if(symb.eq.star) then
198 if(isnum(istk(il1+idec1),n1-idec1,inum1).and.
199 & isnum(istk(il2+idec2),n2-idec2,inum2)) then
200 if(is1.eq.-1) inum1=-inum1
201 if(is2.eq.-1) inum2=-inum2
202 inum=inum1*inum2
203 call intstr(inum,istk(il1),ni,0)
204 il1=il1+ni
205 istk(il+5)=ni+1
206 lstk(top+1)=sadr(il1)
207 goto 9999
208 endif
209 endif
210 is=blanc
211 if(is1.eq.-1.and.is2.ge.0 .or.
212 + is2.eq.-1.and.is1.ge.0) is=minus
213 if(symb.ne.slash.and.
214 & ((n1-abs(is1).eq.1.and.istk(il1+abs(is1)).eq.1).or.
215 & (n1-abs(is1).eq.5.and.iseye(istk(il1+abs(is1))))) ) then
216 if(is.eq.minus) then
217 istk(il1)=is
218 il1=il1+1
219 endif
220 call icopy(n2-abs(is2),istk(il2+abs(is2)),1,istk(il1),1)
221 il1=il1+n2-abs(is2)
222 istk(il+5)=il1-il0+1
223 lstk(top+1)=sadr(il1+1)
224 goto 9999
225 endif
226 idec1=0
227 idec=0
228 if(is1.eq.-1.and.is2.eq.-1) idec1=1
229 if(is.eq.minus.and.is1.eq.0) then
230 idec=1
231 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
232 n1=n1+1
233 endif
234 if(idec1.ne.0) then
235 call icopy(n1-1,istk(il1+idec+1),1,istk(il1+idec),1)
236 n1=n1-1
237 endif
238 il0=il1
239 ill=il1
240 if(is.eq.minus) then
241 istk(ill)=minus
242 ill=ill+1
243 endif
244 il1=il1+n1
245 if(symb.ne.bslash.and.
246 & ((n2-abs(is2).eq.1.and.istk(il2+abs(is2)).eq.1).or.
247 & (n2-abs(is2).eq.5.and.iseye(istk(il2+abs(is2)))))) goto 2041
248 istk(il1)=symb
249 il1=il1+1
250 if(is2.ne.0) then
251 il2=il2+1
252 n2=n2-1
253 endif
254 call icopy(n2,istk(il2),1,istk(il1),1)
255 il1=il1+n2
256 2041 istk(il+5)=il1-il0+1
257 lstk(top+1)=sadr(il1)
258 goto 9999
259c
260 9999 return
261 end
262 \ No newline at end of file
diff --git a/scilab/modules/symbolic/sci_gateway/fortran/sci_rdivf.f b/scilab/modules/symbolic/sci_gateway/fortran/sci_rdivf.f
new file mode 100644
index 0000000..f9484b9
--- /dev/null
+++ b/scilab/modules/symbolic/sci_gateway/fortran/sci_rdivf.f
@@ -0,0 +1,261 @@
1c --------------------------
2c Copyright INRIA
3c --------------------------
4c
5 subroutine scirdivf(fname)
6c ----------------------------
7 character*(*) fname
8 include '../stack.h'
9
10 logical iseye,isnum
11 integer lparen,rparen,star,plus,minus,blanc,slash,bslash,symb
12 integer iadr,sadr
13 data lparen/41/,rparen/42/,star/47/,plus/45/,minus/46/,blanc/40/
14 data slash/48/ ,bslash/49/
15
16 iadr(l)=l+l-1
17 sadr(l)=(l/2)+1
18
19 symb=slash
20
21 il1=iadr(lstk(top-1))
22 il=il1
23 if(istk(il1).ne.10) then
24 err=1
25 call error(55)
26 return
27 endif
28 if(istk(il1+1)*istk(il1+2).ne.1) then
29 err=1
30 call error(36)
31 return
32 endif
33 n1=istk(il1+5)-1
34 il1=il1+6
35 il0=il1
36 call atome(istk(il1),n1,it1,is1)
37 if(symb.ne.bslash) call termf(istk(il1),n1,it1)
38c
39 il2=iadr(lstk(top))
40 if(istk(il2).ne.10) then
41 err=2
42 call error(55)
43 return
44 endif
45 if(istk(il2+1)*istk(il2+2).ne.1) then
46 err=2
47 call error(36)
48 return
49 endif
50 n2=istk(il2+5)-1
51 il2=il2+6
52 top=top-1
53c
54 call atome(istk(il2),n2,it2,is2)
55 if(symb.ne.slash) call termf(istk(il2),n2,it2)
56 if (it2.ne.0) call factf(istk(il2),n2,it2)
57
58c
59 goto (2010,2020,2030,2040) it1+2*it2+1
60c
61c 2 expressions
62 2010 continue
63 idec=0
64 if(is1.ne.1) then
65 call icopy(n1,istk(il1),-1,istk(il1+1),-1)
66 idec=1
67 endif
68 il0=il1
69 istk(il1)=lparen
70 istk(il1+n1+idec)=rparen
71 il1=il1+n1+idec+1
72 istk(il1)=symb
73 il1=il1+1
74 istk(il1)=lparen
75 il1=il1+1
76 if(is2.eq.1) then
77 il2=il2+1
78 n2=n2-1
79 endif
80 call icopy(n2,istk(il2),1,istk(il1),1)
81 il1=il1+n2
82 istk(il1)=rparen
83 il1=il1+1
84 istk(il+5)=il1-il0+1
85 lstk(top+1)=sadr(il1)
86 goto 9999
87 2020 continue
88c un atome et une expression
89 idec=abs(is1)
90 ipar=0
91 if(n1-idec.eq.1 .and.istk(il1+idec).eq.0) then
92 if(symb.eq.bslash) then
93 call error(27)
94 return
95 endif
96 goto 9999
97 endif
98 if(symb.ne.slash.and.
99 & ((n1-idec.eq.1 .and. istk(il1+idec).eq.1).or.
100 & (n1-idec.eq.5.and.iseye(istk(il1+idec))))) then
101c n1=n1-1
102 n1=idec
103 if(is1.eq.-1) then
104 istk(il1+n1)=lparen
105 n1=n1+1
106 ipar=1
107 endif
108 goto 2021
109 else
110 istk(il1+n1)=symb
111 istk(il1+n1+1)=lparen
112 n1=n1+2
113 ipar=1
114 endif
115 2021 if(is2.eq.1) then
116 il2=il2+1
117 n2=n2-1
118 endif
119 call icopy(n2,istk(il2),1,istk(il1+n1),1)
120 n1=n1+n2
121 if(ipar.eq.1) then
122 istk(il1+n1)=rparen
123 n1=n1+1
124 endif
125 istk(il+5)=1+n1
126 lstk(top+1)=sadr(il1+n1)
127 goto 9999
128c expr et atome
129 2030 continue
130 idec=abs(is2)
131 if(n2-idec.eq.1.and.istk(il2+idec).eq.0) then
132 if(symb.eq.slash) then
133 call error(27)
134 return
135 endif
136 istk(il1)=0
137 istk(il+5)=2
138 lstk(top+1)=sadr(il1+1)
139 goto 9999
140 endif
141 if(symb.ne.bslash.and.is2.ge.0
142 & .and.((n2-idec.eq.1.and.istk(il2+idec).eq.1)
143 & .or.(n2-idec.eq.5.and.iseye(istk(il2+idec))))) then
144 istk(il+5)=n1+1
145 lstk(top+1)=sadr(il1+n1)
146 goto 9999
147 endif
148 idec=0
149 if(is1.ne.1) idec=idec+1
150 if(is2.lt.0) idec=idec+1
151 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
152 il0=il1
153 ill=il1
154 if(is2.lt.0) then
155 istk(ill)=minus
156 ill=ill+1
157 endif
158 istk(ill)=lparen
159 istk(il1+n1+idec)=rparen
160 il1=il1+n1+idec+1
161 if(symb.ne.bslash.and.is2.eq.-1.and.
162 & ((n2.eq.2.and.istk(il2+1).eq.1).or.
163 & (n2.eq.6.and.iseye(istk(il2+1))))) goto 2031
164 istk(il1)=symb
165 il1=il1+1
166 if(is2.ne.0) then
167 il2=il2+1
168 n2=n2-1
169 endif
170 call icopy(n2,istk(il2),1,istk(il1),1)
171 il1=il1+n2
172 2031 istk(il+5)=il1-il0+1
173 lstk(top+1)=sadr(il1)
174 goto 9999
175c atome et atome
176 2040 continue
177
178 idec1=abs(is1)
179 if(n1-idec1.eq.1.and.istk(il1+idec1).eq.0) then
180 if(symb.eq.bslash) then
181 call error(27)
182 return
183 endif
184 goto 9999
185 endif
186 idec2=abs(is2)
187 if(n2-idec2.eq.1.and.istk(il2+idec2).eq.0) then
188 if(symb.eq.slash) then
189 call error(27)
190 return
191 endif
192 istk(il1)=0
193 istk(il+5)=2
194 lstk(top+1)=sadr(il1+1)
195 goto 9999
196 endif
197 if(symb.eq.star) then
198 if(isnum(istk(il1+idec1),n1-idec1,inum1).and.
199 & isnum(istk(il2+idec2),n2-idec2,inum2)) then
200 if(is1.eq.-1) inum1=-inum1
201 if(is2.eq.-1) inum2=-inum2
202 inum=inum1*inum2
203 call intstr(inum,istk(il1),ni,0)
204 il1=il1+ni
205 istk(il+5)=ni+1
206 lstk(top+1)=sadr(il1)
207 goto 9999
208 endif
209 endif
210 is=blanc
211 if(is1.eq.-1.and.is2.ge.0 .or.
212 + is2.eq.-1.and.is1.ge.0) is=minus
213 if(symb.ne.slash.and.
214 & ((n1-abs(is1).eq.1.and.istk(il1+abs(is1)).eq.1).or.
215 & (n1-abs(is1).eq.5.and.iseye(istk(il1+abs(is1))))) ) then
216 if(is.eq.minus) then
217 istk(il1)=is
218 il1=il1+1
219 endif
220 call icopy(n2-abs(is2),istk(il2+abs(is2)),1,istk(il1),1)
221 il1=il1+n2-abs(is2)
222 istk(il+5)=il1-il0+1
223 lstk(top+1)=sadr(il1+1)
224 goto 9999
225 endif
226 idec1=0
227 idec=0
228 if(is1.eq.-1.and.is2.eq.-1) idec1=1
229 if(is.eq.minus.and.is1.eq.0) then
230 idec=1
231 call icopy(n1,istk(il1),-1,istk(il1+idec),-1)
232 n1=n1+1
233 endif
234 if(idec1.ne.0) then
235 call icopy(n1-1,istk(il1+idec+1),1,istk(il1+idec),1)
236 n1=n1-1
237 endif
238 il0=il1
239 ill=il1
240 if(is.eq.minus) then
241 istk(ill)=minus
242 ill=ill+1
243 endif
244 il1=il1+n1
245 if(symb.ne.bslash.and.
246 & ((n2-abs(is2).eq.1.and.istk(il2+abs(is2)).eq.1).or.
247 & (n2-abs(is2).eq.5.and.iseye(istk(il2+abs(is2)))))) goto 2041
248 istk(il1)=symb
249 il1=il1+1
250 if(is2.ne.0) then
251 il2=il2+1
252 n2=n2-1
253 endif
254 call icopy(n2,istk(il2),1,istk(il1),1)
255 il1=il1+n2
256 2041 istk(il+5)=il1-il0+1
257 lstk(top+1)=sadr(il1)
258 goto 9999
259c
260 9999 return
261 end