fix import/export of ierode common on Windows
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / badd.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 badd(ny,t,y,ml,mu,p,nrowp)
12 c
13 c ======================================================================
14 c      interface pour l'external add de IMPL
15 c ======================================================================
16 c
17       INCLUDE 'stack.h'
18       integer iadr,sadr
19 c     
20       double precision y(ny),p(nrowp,ny),t(*)
21       logical allowptr
22 c     
23       integer vol,tops,nordre
24       data nordre/2/,mlhs/1/
25 c
26       iadr(l)=l+l-1
27       sadr(l)=(l/2)+1
28 c     
29 c     nordre=external number
30 c     mlhs (mrhs) = number ot output (input) parameters of the 
31 c     external 
32       ierror=0
33       mrhs=3
34 c     
35       ilp=iadr(lstk(top))
36       il=istk(ilp+nordre)
37
38 c     external is a Scilab function
39 c     on return ierror=1 is used to notify to the ode solver that
40 c     scilab was not able to evaluate the external
41       ierror=1
42
43 c     
44 c     transfer of input parameters
45 c+     
46       call ftob(t,1,istk(il+1))
47       if(err.gt.0.or.err1.gt.0) return
48       call ftob(y,ny,istk(il+2))
49       if(err.gt.0.or.err1.gt.0) return
50 c     
51       top=top+1
52       if(top+1.ge.bot) then
53          call error(18)
54          return
55       endif
56       err=lstk(top)+2+ny*ny-lstk(bot)
57       if(err.gt.0) then
58          call error(17)
59          return
60       endif
61       ilp1=iadr(lstk(top))
62       istk(ilp1)=1
63       istk(ilp1+1)=ny
64       istk(ilp1+2)=ny
65       istk(ilp1+3)=0
66       lp1=sadr(ilp1+4)
67       call unsfdcopy(ny*ny,p,1,stk(lp1),1)
68       lstk(top+1)=lp1+ny*ny
69 c     call ftob(p,ny,istk(il+3))
70 c+    
71 c     
72       tops=istk(il)
73       ils=iadr(lstk(tops))
74       if(istk(ils).eq.15) goto 10
75 c+    
76 c     adress of external
77       fin=lstk(tops)
78 c     
79       goto 40
80 c     
81 c     external in a list
82  10   nelt=istk(ils+1)
83       l=sadr(ils+3+nelt)
84       ils=ils+2
85 c     adress of external
86       fin=l
87 c     
88 c     additional parameters
89 c     
90       nelt=nelt-1
91       if(nelt.eq.0) goto 40
92       l=l+istk(ils+1)-istk(ils)
93       vol=istk(ils+nelt+1)-istk(ils+1)
94       if(top+1+nelt.ge.bot) then
95          call error(18)
96          return
97       endif
98       err=lstk(top+1)+vol-lstk(bot)
99       if(err.gt.0) then
100          call error(17)
101          return
102       endif
103       call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
104       do 11 i=1,nelt
105          top=top+1
106          lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
107  11   continue
108       mrhs=mrhs+nelt
109  40   continue
110 c     
111 c     execute scilab external
112 c     
113       pt=pt+1
114       if(pt.gt.psiz) then
115          call error(26)
116          return
117       endif
118       ids(1,pt)=lhs
119       ids(2,pt)=rhs
120       rstk(pt)=1001
121       lhs=mlhs
122       rhs=mrhs
123       niv=niv+1
124       fun=0
125 c     
126       icall=5
127 c
128       include 'callinter.h.f'
129 c     
130  200  lhs=ids(1,pt)
131       rhs=ids(2,pt)
132       pt=pt-1
133       niv=niv-1
134 c+    
135 c     transfer of output parameters of external to fortran
136       call btof(p,ny*ny)
137       if(err.gt.0.or.err1.gt.0) return
138 c+    
139 c     normal return
140       ierror=0
141       return
142 c     
143  9999 continue
144       niv=niv-1
145       if(err1.gt.0) then
146 c     .  the error has been catched
147          lhs=ids(1,pt)
148          rhs=ids(2,pt)
149          pt=pt-1
150          fun=0
151       endif
152       return
153       end