d612b68ee7aeecda43bb3ec2ffd192dccf150a79
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / bbvode.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA
3 c ...
4
5 c This file must be used under the terms of the CeCILL.
6 c This source file is licensed as described in the file COPYING, which
7 c you should have received as part of this distribution.  The terms
8 c are also available at    
9 c http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.txt
10 c
11       subroutine dgsub(ii,z,dg)
12 c ======================================================================
13 c     Soft and Fortrans coded externals for colnew 
14 c ======================================================================
15 c
16       INCLUDE 'stack.h'
17 c      
18       character tmpbuf * (bsiz)      
19       integer iadr,sadr
20       common/iercol/iero
21       double precision z(*), dg(*)
22       common / icolnew/  ncomp,mstar
23       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
24       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
25       integer ii
26       logical allowptr
27       data mlhs/1/,mrhs/2/
28
29       iadr(l)=l+l-1
30       sadr(l)=(l/2)+1
31
32       if (ddt .eq. 4) then
33          write(tmpbuf(1:12),'(3i4)') top,r,sym
34          call basout(io,wte,' dgsub  top:'//tmpbuf(1:4))
35       endif
36
37       if(itdgsub.eq.10) then
38 c       Fortran case 
39         call fcoldg(ii,z,dg)
40         return
41       endif
42 c     external is a Scilab function
43 c+ 
44 c     on return iero=1 is used to notify to the ode solver that
45 c     scilab was not able to evaluate the external
46       iero=1
47
48 c     Putting Fortran arguments on Scilab stack 
49
50       call ftob(dble(ii),1,ki)
51       if(err.gt.0.or.err1.gt.0) return
52       call ftob(z,mstar,kz)
53       if(err.gt.0.or.err1.gt.0) return
54 c+    
55       if(itdgsub.ne.15) then
56          fin=lstk(kdgsub)
57       else
58          ils=iadr(lstk(kdgsub))
59          nelt=istk(ils+1)
60          l=sadr(ils+3+nelt)
61          ils=ils+2
62 c     external adress 
63          fin=l
64 c     Extra arguments in calling list that westore on the Scilab stack
65          call extlarg(l,ils,nelt,mrhs)
66          if(err.gt.0.or.err1.gt.0) return
67       endif
68 c     Macro execution 
69       pt=pt+1
70       if(pt.gt.psiz) then
71          call  error(26)
72          return
73       endif
74       ids(1,pt)=lhs
75       ids(2,pt)=rhs
76       rstk(pt)=1001
77       lhs=mlhs
78       rhs=mrhs
79       niv=niv+1
80       fun=0
81 c     
82       icall=5
83
84       include 'callinter.h'
85  200  lhs=ids(1,pt)
86       rhs=ids(2,pt)
87       pt=pt-1
88       niv=niv-1
89 c+    
90 C     Scilab to Fortran convertion 
91       call btof(dg,mstar)
92       if(err.gt.0.or.err1.gt.0) return
93 c     normal return iero set to 0
94       iero=0
95       return
96 c     
97  9999 continue
98       niv=niv-1
99       if(err1.gt.0) then
100          lhs=ids(1,pt)
101          rhs=ids(2,pt)
102          pt=pt-1
103          fun=0
104       endif
105       return
106       end
107
108
109       subroutine gsub(ii,z,g)
110 c ======================================================================
111 C     Soft and Fortrans coded externals for colnew 
112 c ======================================================================
113       INCLUDE 'stack.h'
114 c      
115       character tmpbuf * (bsiz) 
116       integer iadr,sadr
117       common/iercol/iero
118       double precision z(*), g(*)
119       common / icolnew/  ncomp,mstar
120       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
121       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
122       logical allowptr
123       integer ii
124
125       data mlhs/1/,mrhs/2/
126
127       iadr(l)=l+l-1
128       sadr(l)=(l/2)+1
129
130       if (ddt .eq. 4) then
131          write(tmpbuf(1:12),'(3i4)') top,r,sym
132          call basout(io,wte,' gsub  top:'//tmpbuf(1:4))
133       endif
134
135       if(itgsub.eq.10) then
136 c       Fortran case 
137         call fcolg(ii,z,g)
138         return
139       endif
140
141
142 c     external is a Scilab function
143
144 c     on return iero=1 is used to notify to the ode solver that
145 c     scilab was not able to evaluate the external
146       iero=1
147
148
149 c     Putting Fortran arguments on Scilab stack 
150 c+    
151       call ftob(dble(ii),1,ki)
152       if(err.gt.0.or.err1.gt.0) return
153       call ftob(z,mstar,kz)
154       if(err.gt.0.or.err1.gt.0) return
155 c+    
156       if(itgsub.ne.15) then
157          fin=lstk(kgsub)
158       else
159          ils=iadr(lstk(kgsub))
160          nelt=istk(ils+1)
161          l=sadr(ils+3+nelt)
162          ils=ils+2
163 c     external adress 
164          fin=l
165 c     Extra arguments in calling list that westore on the Scilab stack
166          call extlarg(l,ils,nelt,mrhs)
167          if(err.gt.0.or.err1.gt.0) return
168       endif
169 c     Macro execution 
170       pt=pt+1
171       if(pt.gt.psiz) then
172          call  error(26)
173          return
174       endif
175       ids(1,pt)=lhs
176       ids(2,pt)=rhs
177       rstk(pt)=1001
178       lhs=mlhs
179       rhs=mrhs
180       niv=niv+1
181       fun=0
182 c     
183       icall=5
184
185       include 'callinter.h'
186  200  lhs=ids(1,pt)
187       rhs=ids(2,pt)
188       pt=pt-1
189       niv=niv-1
190 c+    
191 C     Scilab to Fortran convertion 
192       call btof(g,1)
193       if(err.gt.0.or.err1.gt.0) return
194 c     normal return iero set to 0
195       iero=0
196 c+    
197       return
198 c     
199  9999 continue
200       niv=niv-1
201       if(err1.gt.0) then
202          lhs=ids(1,pt)
203          rhs=ids(2,pt)
204          pt=pt-1
205          fun=0
206       endif
207       return
208       end
209
210       subroutine dfsub(x,z,df)
211 c ======================================================================
212 C     Soft and Fortrans coded externals for colnew 
213 c ======================================================================
214       INCLUDE 'stack.h'
215 c
216       character tmpbuf * (bsiz)       
217       integer iadr,sadr
218       common/iercol/iero
219       double precision z(*), df(*),x
220       common / icolnew/  ncomp,mstar
221       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
222       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
223       logical allowptr
224
225       data mlhs/1/,mrhs/2/
226
227       iadr(l)=l+l-1
228       sadr(l)=(l/2)+1
229
230       if (ddt .eq. 4) then
231          write(tmpbuf(1:12),'(3i4)') top,r,sym
232          call basout(io,wte,' dfsub  top:'//tmpbuf(1:4))
233       endif
234
235       if(itdfsub.eq.10) then
236 c       Fortran case 
237         call fcoldf(x,z,df)
238         return
239       endif
240
241 c     external is a Scilab function
242
243 c     on return iero=1 is used to notify to the ode solver that
244 c     scilab was not able to evaluate the external
245       iero=1
246
247
248 c     Putting Fortran arguments on Scilab stack 
249 c+    
250       call ftob(x,1,kx)
251       if(err.gt.0.or.err1.gt.0) return
252       call ftob(z,mstar,kz)
253       if(err.gt.0.or.err1.gt.0) return
254 c+    
255       if(itdfsub.ne.15) then
256          fin=lstk(kdfsub)
257       else
258          ils=iadr(lstk(kdfsub))
259          nelt=istk(ils+1)
260          l=sadr(ils+3+nelt)
261          ils=ils+2
262 c     external adress 
263          fin=l
264 c     Extra arguments in calling list that westore on the Scilab stack
265          call extlarg(l,ils,nelt,mrhs)
266          if(err.gt.0.or.err1.gt.0) return
267       endif
268 c     Macro execution 
269       pt=pt+1
270       if(pt.gt.psiz) then
271          call  error(26)
272          return
273       endif
274       ids(1,pt)=lhs
275       ids(2,pt)=rhs
276       rstk(pt)=1001
277       lhs=mlhs
278       rhs=mrhs
279       niv=niv+1
280       fun=0
281 c     
282       icall=5
283
284       include 'callinter.h'
285  200  lhs=ids(1,pt)
286       rhs=ids(2,pt)
287       pt=pt-1
288       niv=niv-1
289 c+    
290 C     Scilab to Fortran convertion 
291       call btof(df,mstar*ncomp)
292       if(err.gt.0.or.err1.gt.0) return
293 c     normal return iero set to 0
294       iero=0
295 c+    
296       return
297 c     
298  9999 continue
299       niv=niv-1
300       if(err1.gt.0) then
301          lhs=ids(1,pt)
302          rhs=ids(2,pt)
303          pt=pt-1
304          fun=0
305       endif
306       return
307       end
308
309
310       subroutine fsub(x,z,f)
311 c ======================================================================
312 C     Soft and Fortrans coded externals for colnew 
313 c ======================================================================
314       INCLUDE 'stack.h'
315 c
316       character tmpbuf * (bsiz)        
317       integer iadr,sadr
318       common/iercol/iero
319       double precision z(*), f(*),x
320       common / icolnew/  ncomp,mstar
321       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
322       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
323       logical allowptr
324
325       data mlhs/1/,mrhs/2/
326
327       iadr(l)=l+l-1
328       sadr(l)=(l/2)+1
329
330       if (ddt .eq. 4) then
331          write(tmpbuf(1:12),'(3i4)') top,r,sym
332          call basout(io,wte,' fsub  top:'//tmpbuf(1:4))
333       endif
334
335       if(itfsub.eq.10) then
336 c       Fortran case 
337         call fcolf(x,z,f)
338         return
339       endif
340 c     external is a Scilab function
341
342 c     on return iero=1 is used to notify to the ode solver that
343 c     scilab was not able to evaluate the external
344       iero=1
345
346
347 c     Putting Fortran arguments on Scilab stack 
348 c+    
349       call ftob(x,1,kx)
350       if(err.gt.0.or.err1.gt.0) return
351       call ftob(z,mstar,kz)
352       if(err.gt.0.or.err1.gt.0) return
353 c+    
354       if(itfsub.ne.15) then
355          fin=lstk(kfsub)
356       else
357          ils=iadr(lstk(kfsub))
358          nelt=istk(ils+1)
359          l=sadr(ils+3+nelt)
360          ils=ils+2
361 c     external adress 
362          fin=l
363 c     Extra arguments in calling list that westore on the Scilab stack
364          call extlarg(l,ils,nelt,mrhs)
365          if(err.gt.0.or.err1.gt.0) return
366       endif
367 c     Macro execution 
368       pt=pt+1
369       if(pt.gt.psiz) then
370          call  error(26)
371          return
372       endif
373       ids(1,pt)=lhs
374       ids(2,pt)=rhs
375       rstk(pt)=1001
376       lhs=mlhs
377       rhs=mrhs
378       niv=niv+1
379       fun=0
380 c     
381       icall=5
382
383       include 'callinter.h'
384  200  lhs=ids(1,pt)
385       rhs=ids(2,pt)
386       pt=pt-1
387       niv=niv-1
388 c+    
389 C     Scilab to Fortran convertion 
390       call btof(f,ncomp)
391       if(err.gt.0.or.err1.gt.0) return
392 c     normal return iero set to 0
393       iero=0
394 c+    
395       return
396 c     
397  9999 continue
398       niv=niv-1
399       if(err1.gt.0) then
400          lhs=ids(1,pt)
401          rhs=ids(2,pt)
402          pt=pt-1
403          fun=0
404       endif
405       return
406       end
407
408       subroutine dguess(x,z,dmval)
409 c ======================================================================
410 C     Soft and Fortrans coded externals for colnew 
411 c ======================================================================
412       INCLUDE 'stack.h'
413 c
414       character tmpbuf * (bsiz)       
415       integer iadr,sadr
416       common/iercol/iero
417       double precision z(*), dmval(*),x
418       common / icolnew/  ncomp,mstar
419       common / coladr / kfsub,kdfsub,kgsub,kdgsub,kguess,kx,ki,kz
420       common / coltyp / itfsub,itdfsub,itgsub,itdgsub,itguess
421       logical allowptr
422
423       data mlhs/2/,mrhs/1/
424
425       iadr(l)=l+l-1
426       sadr(l)=(l/2)+1
427
428       if (ddt .eq. 4) then
429          write(tmpbuf(1:12),'(3i4)') top,r,sym
430          call basout(io,wte,' guess  top:'//tmpbuf(1:4))
431       endif
432
433       if(itguess.eq.10) then
434 c       Fortran case 
435         call fcolgu(x,z,dmval)
436         return
437       endif
438 c     external is a Scilab function
439
440 c     on return iero=1 is used to notify to the ode solver that
441 c     scilab was not able to evaluate the external
442       iero=1
443
444
445 c     Putting Fortran arguments on Scilab stack 
446 c+    
447       call ftob(x,1,kx)
448       if(err.gt.0.or.err1.gt.0) return
449 c+    
450       if(itguess.ne.15) then
451          fin=lstk(kguess)
452       else
453          ils=iadr(lstk(kguess))
454          nelt=istk(ils+1)
455          l=sadr(ils+3+nelt)
456          ils=ils+2
457 c     external adress 
458          fin=l
459 c     Extra arguments in calling list that westore on the Scilab stack
460          call extlarg(l,ils,nelt,mrhs)
461          if(err.gt.0.or.err1.gt.0) return
462       endif
463 c     Macro execution 
464       pt=pt+1
465       if(pt.gt.psiz) then
466          call  error(26)
467          return
468       endif
469       ids(1,pt)=lhs
470       ids(2,pt)=rhs
471       rstk(pt)=1001
472       lhs=mlhs
473       rhs=mrhs
474       niv=niv+1
475       fun=0
476 c     
477       icall=5
478
479       include 'callinter.h'
480  200  lhs=ids(1,pt)
481       rhs=ids(2,pt)
482       pt=pt-1
483       niv=niv-1
484 c+    
485 C     Scilab to Fortran convertion 
486       call btof(dmval,ncomp)
487       if(err.gt.0.or.err1.gt.0) return
488       call btof(z,mstar)
489       if(err.gt.0.or.err1.gt.0) return
490 c     normal return iero set to 0
491       iero=0
492 c+    
493       return
494 c     
495  9999 continue
496       niv=niv-1
497       if(err1.gt.0) then
498          lhs=ids(1,pt)
499          rhs=ids(2,pt)
500          pt=pt-1
501          fun=0
502       endif
503       return
504       end
505