1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
subroutine bj2(n,t,y,s,ml,mu,jac,nrowj)
c
c ======================================================================
c Gestion des macros externals pour la primitive IMPL
c ======================================================================
c
c Copyright INRIA
INCLUDE '../stack.h'
integer iadr,sadr
c
double precision y(n),s(n),jac(nrowj,n),t(*)
common/ierode/iero
c
logical allowptr
integer vol,tops,nordre
data nordre/3/,mlhs/1/
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
c nordre est le numero d'ordre de cet external dans la structure
c de donnee,
c mlhs (mrhs) est le nombre de parametres de sortie (entree)
c du simulateur
c
iero=0
mrhs=3
c
ilp=iadr(lstk(top))
il=istk(ilp+nordre)
c
c transfert des arguments d'entree minimaux du simulateur
c la valeur de ces arguments vient du contexte fortran (liste d'appel)
c la structure vient du contexte
c+
call ftob(t,1,istk(il+1))
if(err.gt.0) goto 9999
call ftob(y,n,istk(il+2))
if(err.gt.0) goto 9999
call ftob(s,n,istk(il+3))
if(err.gt.0) goto 9999
c+
c
tops=istk(il)
ils=iadr(lstk(tops))
if(istk(ils).eq.15) goto 10
c
c recuperation de l'adresse du simulateur
fin=lstk(tops)
c
goto 40
c cas ou le simulateur est decrit par une liste
10 nelt=istk(ils+1)
l=sadr(ils+3+nelt)
ils=ils+2
c
c recuperation de l'adresse du simulateur
fin=l
c
c gestion des parametres supplementaires du simulateur
c proviennent du contexte (elements de la liste
c decrivant le simulateur
c
nelt=nelt-1
if(nelt.eq.0) goto 40
l=l+istk(ils+1)-istk(ils)
vol=istk(ils+nelt+1)-istk(ils+1)
if(top+1+nelt.ge.bot) then
call error(18)
if(err.gt.0) goto 9999
endif
err=lstk(top+1)+vol-lstk(bot)
if(err.gt.0) then
call error(17)
if(err.gt.0) goto 9999
endif
call unsfdcopy(vol,stk(l),1,stk(lstk(top+1)),1)
do 11 i=1,nelt
top=top+1
lstk(top+1)=lstk(top)+istk(ils+i+1)-istk(ils+i)
11 continue
mrhs=mrhs+nelt
40 continue
c
c execution de la macro definissant le simulateur
c
iero=0
pt=pt+1
if(pt.gt.psiz) then
call error(26)
goto 9999
endif
ids(1,pt)=lhs
ids(2,pt)=rhs
rstk(pt)=1001
lhs=mlhs
rhs=mrhs
niv=niv+1
fun=0
c
icall=5
include '../callinter.h'
c
200 lhs=ids(1,pt)
rhs=ids(2,pt)
pt=pt-1
c+
c transfert des variables de sortie vers fortran
call btof(jac,n*n)
if(err.gt.0) goto 9999
c+
niv=niv-1
return
c
9999 continue
iero=1
niv=niv-1
return
end
|
