1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) Scilab Enterprises - 2013
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.1-en.txt
10 subroutine bpjacd (res, ires, neq, t, y, ydot, rewt, savr,
11 * wk, h, cj, wp, iwp, ier, rpar, ipar)
13 c ======================================================================
14 c Management of external dealing with preconditioning of linear systems.
15 c ======================================================================
22 character tmpbuf * (bsiz)
23 double precision res(*), t, y(*), ydot(*), rewt(*), savr(*),
24 * wk(*), h, cj, wp(*), rpar(*)
25 integer ires, neq, iwp(*), ier, ipar(*)
27 integer vol,tops,nordre,hsize
28 data nordre/5/,mlhs/3/
36 write(tmpbuf(1:12),'(3i4)') top,r,sym
37 call basout(io,wte,' bpjacd top:'//tmpbuf(1:4))
39 c nordre is the external's order number in the data structure,
40 c mlhs (mrhs) is the number of output (input) parameters
52 if(istk(ils).eq.10) then
53 c Fortran simulator case
54 call fpjacd (res, ires, neq, t, y, ydot, rewt, savr,
55 * wk, h, cj, wp, iwp, ier, rpar, ipar)
58 c external is a Scilab function
60 c On return ierror=1 is used to notify to the ode solver that
61 c scilab was not able to evaluate the external
64 c Putting Fortran arguments on Scilab stack
66 c Minimum entry arguments for the simulator. The value of these arguments
67 c comes from the Fortran context (call list)
71 call ftob(dneq,1,istk(il+1))
72 if(err.gt.0.or.err1.gt.0) return
73 call ftob(t,1,istk(il+1))
74 if(err.gt.0.or.err1.gt.0) return
75 call ftob(y,neq,istk(il+2))
76 if(err.gt.0.or.err1.gt.0) return
77 call ftob(ydot,neq,istk(il+2))
78 if(err.gt.0.or.err1.gt.0) return
79 call ftob(h,1,istk(il+1))
80 if(err.gt.0.or.err1.gt.0) return
81 call ftob(cj,1,istk(il+1))
82 if(err.gt.0.or.err1.gt.0) return
83 call ftob(rewt,neq,istk(il+2))
84 if(err.gt.0.or.err1.gt.0) return
85 call ftob(savr,neq,istk(il+2))
86 if(err.gt.0.or.err1.gt.0) return
89 if(istk(ils).eq.15) goto 10
91 c Retrieving the simulator's address
95 c If the simulator is defined by a list
100 c Retrieving the simulator's address
103 c Managing the additional simulator parameters coming from
104 c the context (elements of the list describing the simulator)
108 l=l+istk(ils+1)-istk(ils)
109 vol=istk(ils+nelt+1)-istk(ils+1)
110 if(top+1+nelt.ge.bot) then
114 err=lstk(top+1)+vol-lstk(bot)
119 call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
122 lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
128 c Executing the macro defining the simulator
145 include 'callinter.h.f'
152 c Transferring the output to Fortran
154 if(err.gt.0.or.err1.gt.0) return
155 c call btof(iwp,2*neq*neq)
158 n=istk(il2+1)*istk(il2+2)*(istk(il2+3)+1)
160 c Test if the variable on the stack has same type and size as the theoretical iwp
161 if (istk(il2).ne.1.or.n.ne.liwp) then
170 if(err.gt.0.or.err1.gt.0) return
173 if(err.gt.0.or.err1.gt.0) return
176 c Normal return ierror set to 0