Fix f2c compilation
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / bpsold.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 bpsold (neq, t, y, ydot, savr, wk, cj, wght,
11      *                     wp, iwp, b, eplin, ier, rpar, ipar)
12 c
13 c ======================================================================
14 c     Management of external dealing with preconditioned 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 t,y(*),ydot(*),savr(*),wk(*),cj,wght(*),wp(*),
25      *                  b(*),eplin,rpar(*)
26       integer neq,iwp(*),ier,ipar(*)
27       integer vol,tops,nordre,hsize
28       data nordre/4/,mlhs/2/
29 c
30       iadr(l)=l+l-1
31       sadr(l)=(l/2)+1
32 c
33 c
34       if (ddt .eq. 4) then
35          write(tmpbuf(1:12),'(3i4)') top,r,sym
36          call basout(io,wte,' bpsold  top:'//tmpbuf(1:4))
37       endif
38 c     nordre is the external's order number in the data structure,
39 c     mlhs (mrhs) is the number of output (input) parameters
40 c     of the simulator
41 c
42       mrhs=3
43       iero=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     Fortran simulator case
53          call fpsold(neq, t, y, ydot, savr, wk, cj, wght,
54      *                wp, iwp, b, eplin, ier, rpar, ipar)
55          return
56       endif
57 c     external is a Scilab function
58
59 c     On return iero=1 is used to notify to the ode solver that
60 c     scilab was not able to evaluate the external
61       iero=1
62
63 c     Putting Fortran arguments on Scilab stack
64 c
65 c     Minimum entry arguments for the simulator. The value of these arguments
66 c     comes from the Fortran context (call list)
67 c+
68 c
69       lwp = neq*neq
70       call ftob(wp,lwp,istk(il+1))
71       if(err.gt.0.or.err1.gt.0) return
72 c      call ftob(iwp,isize,istk(il+2))
73       ilx=iadr(lstk(istk(il+2)))
74       hsize=4
75       liwp = 2*neq*neq
76       if(top.ge.bot) then
77          call error(18)
78          return
79       endif
80       top=top+1
81       il2=iadr(lstk(top))
82       err=lstk(top)+sadr(hsize)+liwp-lstk(bot)
83       if(err.gt.0) then
84          call error(17)
85          return
86       endif
87       call icopy(hsize,istk(ilx),1,istk(il2),1)
88       l=sadr(il2+hsize)
89       do 900 i=1,liwp
90          stk(l+i-1) = iwp(i)
91 900   continue
92       lstk(top+1)=l+liwp
93       if(err.gt.0.or.err1.gt.0) return
94       call ftob(b,neq,istk(il+3))
95       if(err.gt.0.or.err1.gt.0) return
96 c+
97 c
98       if(istk(ils).eq.15) goto 10
99 c
100 c     Retrieving the simulator's address
101       fin=lstk(tops)
102 c
103       goto 40
104 c     If the simulator is defined by a list
105  10   nelt=istk(ils+1)
106       l=sadr(ils+3+nelt)
107       ils=ils+2
108 c
109 c     Retrieving the simulator's address
110       fin=l
111 c
112 c     Managing the additional simulator parameters coming from
113 c     the context (elements of the list describing the simulator)
114 c
115       nelt=nelt-1
116       if(nelt.ne.0) then
117          l=l+istk(ils+1)-istk(ils)
118          vol=istk(ils+nelt+1)-istk(ils+1)
119          if(top+1+nelt.ge.bot) then
120             call error(18)
121             return
122          endif
123          err=lstk(top+1)+vol-lstk(bot)
124          if(err.gt.0) then
125             call error(17)
126             return
127          endif
128          call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
129          do 11 i=1,nelt
130             top=top+1
131             lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
132  11      continue
133          mrhs=mrhs+nelt
134       endif
135  40   continue
136 c
137 c     Executing the macro defining the simulator
138 c
139       pt=pt+1
140       if(pt.gt.psiz) then
141          call  error(26)
142          return
143       endif
144       ids(1,pt)=lhs
145       ids(2,pt)=rhs
146       rstk(pt)=1001
147       lhs=mlhs
148       rhs=mrhs
149       niv=niv+1
150       fun=0
151 c
152       icall=5
153
154       include 'callinter.h'
155 c
156  200  lhs=ids(1,pt)
157       rhs=ids(2,pt)
158       pt=pt-1
159       niv=niv-1
160 c+
161 c     Transferring the output to Fortran
162       call btof(ier,1)
163       if(err.gt.0.or.err1.gt.0) return
164       call btof(b,neq)
165       if(err.gt.0.or.err1.gt.0) return
166 c+
167 c     Normal return iero set to 0
168       iero=0
169       return
170 c
171  9999 continue
172       niv=niv-1
173       if(err1.gt.0) then
174          lhs=ids(1,pt)
175          rhs=ids(2,pt)
176          pt=pt-1
177          fun=0
178       endif
179       return
180       end
181