9101c8d8f1163cc7d81d6ce52331f54ec17583ba
[scilab.git] / scilab / modules / differential_equations / sci_gateway / fortran / bint2d.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       double precision function bint2d(x,y)
12 c
13 c ======================================================================
14 c     gestion des macros externals pour le primitive INTG
15 c ======================================================================
16 c
17       INCLUDE 'stack.h'
18       integer iadr,sadr
19 c     
20       double precision x,y,xx
21       integer       iero
22       common/iertwo/iero
23       logical allowptr
24 c     
25       integer vol,tops,nordre
26       data nordre/1/,mlhs/1/
27 c
28       iadr(l)=l+l-1
29       sadr(l)=(l/2)+1
30 c     
31 c     nordre est le numero d'ordre de cet external dans la structure
32 c     de donnee,
33 c     mlhs (mrhs) est le nombre de parametres de sortie (entree)
34 c     du simulateur 
35 c     
36       iero=0
37       mrhs=2
38 c     
39       ilp=iadr(lstk(top))
40       il=istk(ilp+nordre)
41
42 c     external is a Scilab function
43
44 c     on return iero=1 is used to notify to the ode solver that
45 c     scilab was not able to evaluate the external
46       iero=1
47 c     Putting Fortran arguments on Scilab stack 
48
49 c+    
50       call ftob(x,1,istk(il+1))
51       if(err.gt.0.or.err1.gt.0) return
52       call ftob(y,1,istk(il+2))
53       if(err.gt.0.or.err1.gt.0) return
54 c+    
55 c     
56       tops=istk(il)
57       ils=iadr(lstk(tops))
58       if(istk(ils).eq.15) goto 10
59 c     
60 c     recuperation de l'adresse du simulateur
61       fin=lstk(tops)
62 c     
63       goto 40
64 c     cas ou le simulateur est decrit par une liste
65  10   nelt=istk(ils+1)
66       l=sadr(ils+3+nelt)
67       ils=ils+2
68 c     
69 c     recuperation de l'adresse du simulateur
70       fin=l
71 c     
72 c     gestion des parametres supplementaires du simulateur
73 c     proviennent du contexte  (elements de la liste
74 c     decrivant le simulateur
75 c     
76       nelt=nelt-1
77       if(nelt.eq.0) goto 40
78       l=l+istk(ils+1)-istk(ils)
79       vol=istk(ils+nelt+1)-istk(ils+1)
80       if(top+1+nelt.ge.bot) then
81          call error(18)
82          return
83       endif
84       err=lstk(top+1)+vol-lstk(bot)
85       if(err.gt.0) then
86          call error(17)
87          return
88       endif
89       call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
90       do 11 i=1,nelt
91          top=top+1
92          lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
93  11   continue
94       mrhs=mrhs+nelt
95  40   continue
96 c     
97 c     execution de la macro definissant le simulateur
98 c     
99       pt=pt+1
100       if(pt.gt.psiz) then
101          call error(26)
102          return
103       endif
104       ids(1,pt)=lhs
105       ids(2,pt)=rhs
106       rstk(pt)=1001
107       lhs=mlhs
108       rhs=mrhs
109       niv=niv+1
110       fun=0
111 c     
112 c     
113       icall=5
114
115       include 'callinter.h.f'
116 c     
117  200  lhs=ids(1,pt)
118       rhs=ids(2,pt)
119       pt=pt-1
120       niv=niv-1
121 c+    
122 c     transfert des variables  de sortie vers fortran
123       call btof(xx,1)
124       bint2d=xx
125       if(err.gt.0.or.err1.gt.0) return
126 c     normal return iero set to 0
127       iero=0 
128       return
129
130 c     
131  9999 continue
132       niv=niv-1
133       if(err1.gt.0) then
134          lhs=ids(1,pt)
135          rhs=ids(2,pt)
136          pt=pt-1
137          fun=0
138       endif
139       bint2d=0.0d0
140       return
141       end