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