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