fix import/export of ierode common on Windows
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / bresd.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 bresd(t,y,ydot,res,ires,rpar,ipar)
12 c     
13 c ======================================================================
14 c     external "soft" management dealing with
15 c     ddassl residual calculation
16 c ======================================================================
17 c
18       INCLUDE 'stack.h'
19       integer iadr,sadr
20 c     
21       logical allowptr
22 c      
23       character tmpbuf * (bsiz) 
24       double precision t, y(*),ydot(*),res(*),rpar(*)
25       integer ires,ipar(*)
26       integer vol,tops,nordre
27       data nordre/1/,mlhs/2/
28 c
29       iadr(l)=l+l-1
30       sadr(l)=(l/2)+1
31 c     
32 c
33       if (ddt .eq. 4) then
34          write(tmpbuf(1:12),'(3i4)') top,r,sym
35          call basout(io,wte,' bresd  top:'//tmpbuf(1:4))
36       endif
37 c     nordre is the order number of that external in the
38 c     data structure,
39 c     mlhs (mrhs) is the number of output (input) parameters
40 c     of the simulator
41 c     
42       mrhs=3
43       ierror=0
44 c     
45       ilp=iadr(lstk(top))
46       il=istk(ilp+nordre)
47 c
48       tops=istk(il)
49       ils=iadr(lstk(tops))
50 c
51       if(istk(ils).eq.10) then
52 c     Case of a Fortran simulator
53          call fresd(t,y,ydot,res,ires,rpar,ipar)
54          return
55       endif
56 c     external is a Scilab function
57
58 c     On return ierror=1 is used to notify to the ode solver that
59 c     scilab was not able to evaluate the external
60       ierror=1
61
62 c     Putting Fortran arguments on Scilab stack 
63 c     
64 c     Transferring the minimal input arguments of the simulator
65 c     their value comes from the Fortran context (call list)
66 c     the structure comes from the context
67 c+    
68       neq=istk(il+1)
69       call ftob(t,1,istk(il+2))
70       if(err.gt.0.or.err1.gt.0) return
71       call ftob(y,neq,istk(il+3))
72       if(err.gt.0.or.err1.gt.0) return
73       call ftob(ydot,neq,istk(il+3))
74       if(err.gt.0.or.err1.gt.0) return
75 c+    
76 c     
77       if(istk(ils).eq.15) goto 10
78 c     
79 c     Retrieving the simulator's address
80       fin=lstk(tops)
81 c     
82       goto 40
83 c     Case when the simulator is described by a list
84  10   nelt=istk(ils+1)
85       l=sadr(ils+3+nelt)
86       ils=ils+2
87 c     
88 c     Retrieving the simulator's address
89       fin=l
90 c     
91 c     Managing the additional simulator parameters coming from
92 c     the context (elements of the list describing the simulator)
93 c     
94       nelt=nelt-1
95       if(nelt.ne.0) then
96          l=l+istk(ils+1)-istk(ils)
97          vol=istk(ils+nelt+1)-istk(ils+1)
98          if(top+1+nelt.ge.bot) then
99             call error(18)
100             return
101          endif
102          err=lstk(top+1)+vol-lstk(bot)
103          if(err.gt.0) then
104             call error(17)
105             return
106          endif
107          call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
108          do 11 i=1,nelt
109             top=top+1
110             lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
111  11      continue
112          mrhs=mrhs+nelt
113       endif
114  40   continue
115 c     
116 c     Running the macro defining the simulator
117 c     
118       pt=pt+1
119       if(pt.gt.psiz) then
120          call  error(26)
121          return
122       endif
123       ids(1,pt)=lhs
124       ids(2,pt)=rhs
125       rstk(pt)=1001
126       lhs=mlhs
127       rhs=mrhs
128       niv=niv+1
129       fun=0
130 c     
131       icall=5
132
133       include 'callinter.h.f'
134 c     
135  200  lhs=ids(1,pt)
136       rhs=ids(2,pt)
137       pt=pt-1
138       niv=niv-1
139 c+    
140 c     Transferring the output to Fortran
141       call btof(res,1)
142       if(err.gt.0.or.err1.gt.0) return
143       ires=res(1)
144       call btof(res,neq)
145       if(err.gt.0.or.err1.gt.0) return
146 c+    
147 c     normal return ierror set to 0
148       ierror=0 
149       return
150 c     
151  9999 continue
152       niv=niv-1
153       if(err1.gt.0) then
154          lhs=ids(1,pt)
155          rhs=ids(2,pt)
156          pt=pt-1
157          fun=0
158       endif
159       return
160       end
161