884fcd1a21664046263d2c6c4e35cc28f4ee239e
[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 c     nordre est le numero d'ordre de cet external dans la structure
33 c     de donnee,
34 c     mlhs (mrhs) est le nombre de parametres de sortie (entree)
35 c     du simulateur 
36 c     
37       iero=0
38       mrhs=1
39 c     
40       ilp=iadr(lstk(top))
41       il=istk(ilp+nordre)
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(t,1,istk(il+1))
51       if(err.gt.0.or.err1.gt.0) return
52
53 c+    
54 c     
55       tops=istk(il)
56       ils=iadr(lstk(tops))
57       if(istk(ils).eq.15) goto 10
58 c     
59 c     recuperation de l'adresse du simulateur
60       fin=lstk(tops)
61 c     
62       goto 40
63 c     cas ou le simulateur est decrit par une liste
64  10   nelt=istk(ils+1)
65       l=sadr(ils+3+nelt)
66       ils=ils+2
67 c     
68 c     recuperation de l'adresse du simulateur
69       fin=l
70 c     
71 c     gestion des parametres supplementaires du simulateur
72 c     proviennent du contexte  (elements de la liste
73 c     decrivant le simulateur
74 c     
75       nelt=nelt-1
76       if(nelt.eq.0) goto 40
77       l=l+istk(ils+1)-istk(ils)
78       vol=istk(ils+nelt+1)-istk(ils+1)
79       if(top+1+nelt.ge.bot) then
80          call error(18)
81          return
82       endif
83       err=lstk(top+1)+vol-lstk(bot)
84       if(err.gt.0) then
85          call error(17)
86          return
87       endif
88       call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
89       do 11 i=1,nelt
90          top=top+1
91          lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
92  11   continue
93       mrhs=mrhs+nelt
94  40   continue
95 c     
96 c     execution de la macro definissant le simulateur
97 c     
98       pt=pt+1
99       if(pt.gt.psiz) then
100          call error(26)
101          return
102       endif
103       ids(1,pt)=lhs
104       ids(2,pt)=rhs
105       rstk(pt)=1001
106       lhs=mlhs
107       rhs=mrhs
108       niv=niv+1
109       fun=0
110 c     
111 c     
112       icall=5
113
114       include 'callinter.h.f'
115 c     
116  200  lhs=ids(1,pt)
117       rhs=ids(2,pt)
118       pt=pt-1
119       niv=niv-1
120 c+    
121 c     transfert des variables  de sortie vers fortran
122       call btof(xx,1)
123       bintg=xx
124       if(err.gt.0.or.err1.gt.0) return
125 c     normal return iero set to 0
126       iero=0 
127       return
128 c     
129  9999 continue
130       niv=niv-1
131       if(err1.gt.0) then
132          lhs=ids(1,pt)
133          rhs=ids(2,pt)
134          pt=pt-1
135          fun=0
136       endif
137       bintg=0.0d0
138       return
139       end