Fix f2c compilation
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / bpjacd.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) Scilab Enterprises - 2013
3 c
4 c This file must be used under the terms of the CeCILL.
5 c This source file is licensed as described in the file COPYING, which
6 c you should have received as part of this distribution.  The terms
7 c are also available at
8 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
9 c
10       subroutine bpjacd (res, ires, neq, t, y, ydot, rewt, savr,
11      *                     wk, h, cj, wp, iwp, ier, rpar, ipar)
12 c
13 c ======================================================================
14 c     Management of external dealing with preconditioning of linear systems.
15 c ======================================================================
16 c
17       INCLUDE 'stack.h'
18       integer iadr,sadr
19 c
20       common/ierode/iero
21       logical allowptr
22 c
23       character tmpbuf * (bsiz)
24       double precision res(*), t, y(*), ydot(*), rewt(*), savr(*),
25      *                  wk(*), h, cj, wp(*), rpar(*)
26       integer ires, neq, iwp(*), ier, ipar(*)
27       double precision dneq
28       integer vol,tops,nordre,hsize
29       data nordre/5/,mlhs/3/
30 c
31       iadr(l)=l+l-1
32       sadr(l)=(l/2)+1
33 c
34 c
35
36       if (ddt .eq. 4) then
37          write(tmpbuf(1:12),'(3i4)') top,r,sym
38          call basout(io,wte,' bpjacd  top:'//tmpbuf(1:4))
39       endif
40 c     nordre is the external's order number in the data structure,
41 c     mlhs (mrhs) is the number of output (input) parameters
42 c     of the simulator
43 c
44       mrhs=8
45       iero=0
46 c
47       ilp=iadr(lstk(top))
48       il=istk(ilp+nordre)
49 c
50       tops=istk(il)
51       ils=iadr(lstk(tops))
52 c
53       if(istk(ils).eq.10) then
54 c     Fortran simulator case
55          call fpjacd (res, ires, neq, t, y, ydot, rewt, savr,
56      *                wk, h, cj, wp, iwp, ier, rpar, ipar)
57          return
58       endif
59 c     external is a Scilab function
60
61 c     On return iero=1 is used to notify to the ode solver that
62 c     scilab was not able to evaluate the external
63       iero=1
64
65 c     Putting Fortran arguments on Scilab stack
66 c
67 c     Minimum entry arguments for the simulator. The value of these arguments
68 c     comes from the Fortran context (call list)
69 c+
70 c     function res
71       dneq = neq
72       call ftob(dneq,1,istk(il+1))
73       if(err.gt.0.or.err1.gt.0) return
74       call ftob(t,1,istk(il+1))
75       if(err.gt.0.or.err1.gt.0) return
76       call ftob(y,neq,istk(il+2))
77       if(err.gt.0.or.err1.gt.0) return
78       call ftob(ydot,neq,istk(il+2))
79       if(err.gt.0.or.err1.gt.0) return
80       call ftob(h,1,istk(il+1))
81       if(err.gt.0.or.err1.gt.0) return
82       call ftob(cj,1,istk(il+1))
83       if(err.gt.0.or.err1.gt.0) return
84       call ftob(rewt,neq,istk(il+2))
85       if(err.gt.0.or.err1.gt.0) return
86       call ftob(savr,neq,istk(il+2))
87       if(err.gt.0.or.err1.gt.0) return
88 c+
89 c
90       if(istk(ils).eq.15) goto 10
91 c
92 c     Retrieving the simulator's address
93       fin=lstk(tops)
94 c
95       goto 40
96 c     If the simulator is defined by a list
97  10   nelt=istk(ils+1)
98       l=sadr(ils+3+nelt)
99       ils=ils+2
100 c
101 c     Retrieving the simulator's address
102       fin=l
103 c
104 c     Managing the additional simulator parameters coming from
105 c     the context (elements of the list describing the simulator)
106 c
107       nelt=nelt-1
108       if(nelt.ne.0) then
109          l=l+istk(ils+1)-istk(ils)
110          vol=istk(ils+nelt+1)-istk(ils+1)
111          if(top+1+nelt.ge.bot) then
112             call error(18)
113             return
114          endif
115          err=lstk(top+1)+vol-lstk(bot)
116          if(err.gt.0) then
117             call error(17)
118             return
119          endif
120          call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
121          do 11 i=1,nelt
122             top=top+1
123             lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
124  11      continue
125          mrhs=mrhs+nelt
126       endif
127  40   continue
128 c
129 c     Executing the macro defining the simulator
130 c
131       pt=pt+1
132       if(pt.gt.psiz) then
133          call  error(26)
134          return
135       endif
136
137       ids(1,pt)=lhs
138       ids(2,pt)=rhs
139       rstk(pt)=1001
140       lhs=mlhs
141       rhs=mrhs
142       niv=niv+1
143       fun=0
144 c
145       icall=5
146       include 'callinter.h'
147 c
148  200  lhs=ids(1,pt)
149       rhs=ids(2,pt)
150       pt=pt-1
151       niv=niv-1
152 c+
153 c     Transferring the output to Fortran
154       call btof(ier,1)
155       if(err.gt.0.or.err1.gt.0) return
156 c      call btof(iwp,2*neq*neq)
157       il2=iadr(lstk(top))
158       hsize=4
159       n=istk(il2+1)*istk(il2+2)*(istk(il2+3)+1)
160       liwp = 2*neq*neq
161 c     Test if the variable on the stack has same type and size as the theoretical iwp
162       if (istk(il2).ne.1.or.n.ne.liwp) then
163          call error(98)
164          return
165       endif
166       lx=sadr(il2+hsize)
167       do 900 i=1,liwp
168          iwp(i) = stk(lx+i-1)
169 900   continue
170       top = top-1
171       if(err.gt.0.or.err1.gt.0) return
172       lwp = neq*neq
173       call btof(wp,lwp)
174       if(err.gt.0.or.err1.gt.0) return
175 c+
176
177 c     Normal return iero set to 0
178       iero=0
179       return
180 c
181  9999 continue
182       niv=niv-1
183       if(err1.gt.0) then
184          lhs=ids(1,pt)
185          rhs=ids(2,pt)
186          pt=pt-1
187          fun=0
188       endif
189       return
190       end
191