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