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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
c Copyright (C) INRIA
c
c This file must be used under the terms of the CeCILL.
c This source file is licensed as described in the file COPYING, which
c you should have received as part of this distribution. The terms
c are also available at
c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
c
subroutine boptim(iero,n,x,f,g,izs,rzs,dzs)
c
c ======================================================================
c gestion des macros externals pour la primitive OPTIM
c ======================================================================
c
INCLUDE 'stack.h'
integer iadr,sadr
c
integer tops,vol
integer izs(*)
real rzs(*)
logical allowptr
c+
double precision x(n),f(*),g(n),dzs(*)
double precision xind
data nordre/1/,mlhs/3/
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
indsim=iero
mrhs=2
c
ilp=iadr(lstk(top))
il=istk(ilp+nordre)
c on return iero=0 is used to notify to the solver that
c scilab was not able to evaluate the external
iero=0
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(x,n,istk(il+1))
if(err.gt.0.or.err1.gt.0) return
call ftob(dble(indsim),1,istk(il+2))
if(err.gt.0.or.err1.gt.0) return
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)
return
endif
err=lstk(top+1)+vol-lstk(bot)
if(err.gt.0) then
call error(17)
return
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
pt=pt+1
if(pt.gt.psiz) then
call error(26)
return
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
niv=niv-1
c+
c transfert des variables de sortie vers fortran
call btof(xind,1)
indsim=int(xind)
if(err.gt.0.or.err1.gt.0) return
call btof(g,n)
if(err.gt.0.or.err1.gt.0) return
call btof(f,1)
if(err.gt.0.or.err1.gt.0) return
c+
c normal return iero set to 0
iero=indsim
return
c
9999 continue
niv=niv-1
if(err1.gt.0) then
lhs=ids(1,pt)
rhs=ids(2,pt)
pt=pt-1
fun=0
endif
return
end
|
