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 bjac(ny,t,y,ml,mu,jac,nrowj)
c
c Copyright INRIA
INCLUDE '../stack.h'
integer iadr,sadr
c
double precision y(ny),jac(nrowj,ny),t(*)
common/ierode/iero
c
logical allowptr
integer vol,tops,nordre
data nordre/2/,mlhs/1/
c
iadr(l)=l+l-1
sadr(l)=(l/2)+1
c
iero=0
mrhs=2
c
ilp=iadr(lstk(top))
il=istk(ilp+nordre)
c
tops=istk(il)
ils=iadr(lstk(tops))
c
if(istk(ils).eq.10) then
c cas d'un simulateur en fortran
call fjac(ny,t,y,ml,mu,jac,nrowj)
return
endif
c
c transfert des arguments d'entree minimaux du simulateur
c la valeur de ces arguments vient du contexte fortran (liste d'appel)
c+
call ftob(t,1,istk(il+1))
call ftob(y,ny,istk(il+2))
c+
c
c
c recuperation de l'adresse du simulateur
fin=lstk(tops)
c
if(istk(ils).eq.15) then
c cas ou le simulateur est decrit par une liste
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
endif
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
if(ml.gt.0.or.mu.gt.0) then
mm=ml+mu+1
call btofm(jac,nrowj,mm,ny)
else
nnn=ny*ny
call btof(jac,nnn)
endif
if(err.gt.0) goto 9999
c+
niv=niv-1
return
c
9999 continue
iero=1
niv=niv-1
return
end
|
