← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to routines/scicos/coselm.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/scicos/coselm.f
 
1
      subroutine coselm
 
2
c ====================================================================
 
3
c
 
4
c     evaluate scicos utility functions
 
5
c
 
6
c ====================================================================
 
7
c
 
8
c     Copyright INRIA
 
9
      INCLUDE '../stack.h'
 
10
      integer id(nsiz)
 
11
      integer kfun
 
12
      common /curblk/ kfun
 
13
      double precision ptr
 
14
      integer iadr,sadr
 
15
c     
 
16
      iadr(l)=l+l-1
 
17
      sadr(l)=(l/2)+1
 
18
 
 
19
c
 
20
      if (ddt .eq. 4) then
 
21
         write(buf(1:4),'(i4)') fin
 
22
         call basout(io,wte,' coselm '//buf(1:4))
 
23
      endif
 
24
c
 
25
c     functions/fin
 
26
c     var2vec  vec2var get_import set_import get_curblk getlabel
 
27
c       1          2       3         4         5          6
 
28
c
 
29
c     
 
30
      goto(10,20,30,40,50,60) fin
 
31
 
 
32
c     var2vec
 
33
 10   continue
 
34
      if (rhs .ne. 1) then
 
35
         call error(39)
 
36
         return
 
37
      endif
 
38
      if (lhs .ne. 1) then
 
39
         call error(41)
 
40
         return
 
41
      endif
 
42
c      if(istk(il).eq.1) return
 
43
      il=iadr(lstk(top))
 
44
      il1=il
 
45
      l1=sadr(il1+4)
 
46
      n=lstk(top+1)-lstk(top)
 
47
      call unsfdcopy(n,stk(lstk(top)),-1,stk(l1),-1)
 
48
      istk(il1)=1
 
49
      istk(il1+1)=n
 
50
      istk(il1+2)=1
 
51
      istk(il1+3)=0
 
52
      lstk(top+1)=l1+n
 
53
      goto 999
 
54
c
 
55
c     vec2var
 
56
 20   continue
 
57
      if (rhs .ne. 1) then
 
58
         call error(39)
 
59
         return
 
60
      endif
 
61
      if (lhs .ne. 1) then
 
62
         call error(41)
 
63
         return
 
64
      endif
 
65
      il1=iadr(lstk(top))
 
66
      if(istk(il1).ne.1) then
 
67
         err=1
 
68
         call error(44)
 
69
         return
 
70
      endif
 
71
      l1=sadr(il1+4)
 
72
 
 
73
      n=lstk(top+1)-l1
 
74
      call unsfdcopy(n,stk(l1),1,stk(lstk(top)),1)
 
75
      lstk(top+1)=lstk(top)+n
 
76
      goto 999
 
77
c
 
78
 30   continue
 
79
c     getscicosvars
 
80
      call intgetscicosvars
 
81
      return
 
82
c
 
83
 40   continue
 
84
c     setscicosvars
 
85
      call intgetscicosvars
 
86
      return
 
87
c
 
88
c     curblock
 
89
 50   continue
 
90
      call intcurblk
 
91
      goto 999
 
92
 
 
93
c     getblocklabel
 
94
 60   continue
 
95
      call intgetlabel
 
96
      goto 999
 
97
c
 
98
 999  return
 
99
      end
 
100
 
 
101
      subroutine intcurblk
 
102
      include '../stack.h'
 
103
      integer kfun
 
104
      common /curblk/ kfun
 
105
      integer iadr, sadr
 
106
      iadr(l)=l+l-1
 
107
      sadr(l)=(l/2)+1
 
108
 
 
109
      top=top+1
 
110
      il=iadr(lstk(top))
 
111
      istk(il)=1
 
112
      istk(il+1)=1
 
113
      istk(il+2)=1
 
114
      istk(il+3)=0
 
115
      l=sadr(il+4)
 
116
      stk(l)=kfun
 
117
      lstk(top+1)=l+1
 
118
      return
 
119
      end
 
120
 
 
121
      subroutine intgetscicosvars
 
122
      include '../stack.h'
 
123
      integer kfun
 
124
      common /curblk/ kfun
 
125
      integer vol,type,getscicosvars,ierr
 
126
      double precision ptr
 
127
      external getscicosvars
 
128
      integer iadr, sadr
 
129
      iadr(l)=l+l-1
 
130
      sadr(l)=(l/2)+1
 
131
 
 
132
      if(rhs.ne.1) then
 
133
         call error(39)
 
134
         return
 
135
      endif
 
136
      if (lhs .ne. 1) then
 
137
         call error(41)
 
138
         return
 
139
      endif
 
140
      il1=iadr(lstk(top))
 
141
      if(istk(il1).ne.10) then
 
142
         err=1
 
143
         call error(55)
 
144
         return
 
145
      endif
 
146
c     
 
147
      if(istk(il1+1)*istk(il1+2).ne.1) then
 
148
         err=1
 
149
         call error(36)
 
150
         return
 
151
      endif
 
152
c     
 
153
      mn1=1
 
154
      id1=il1+4
 
155
      l1=id1+mn1+1
 
156
      vol=istk(id1+mn1)-1
 
157
      call cvstr(vol,istk(l1),buf,1)
 
158
c
 
159
      if(buf(1:vol).eq.'x') then
 
160
        ierr=getscicosvars(1,ptr,nv,type)
 
161
      elseif(buf(1:vol).eq.'xptr') then
 
162
        ierr=getscicosvars(2,ptr,nv,type)
 
163
      elseif(buf(1:vol).eq.'z') then
 
164
        ierr=getscicosvars(3,ptr,nv,type)
 
165
      elseif(buf(1:vol).eq.'zptr') then
 
166
        ierr=getscicosvars(4,ptr,nv,type)
 
167
      elseif(buf(1:vol).eq.'rpar') then
 
168
        ierr=getscicosvars(5,ptr,nv,type)
 
169
      elseif(buf(1:vol).eq.'rpptr') then
 
170
        ierr=getscicosvars(6,ptr,nv,type)
 
171
      elseif(buf(1:vol).eq.'ipar') then
 
172
        ierr=getscicosvars(7,ptr,nv,type)
 
173
      elseif(buf(1:vol).eq.'ipptr') then
 
174
        ierr=getscicosvars(8,ptr,nv,type)
 
175
      elseif(buf(1:vol).eq.'outtb') then
 
176
        ierr=getscicosvars(9,ptr,nv,type)
 
177
      elseif(buf(1:vol).eq.'inpptr') then
 
178
        ierr=getscicosvars(10,ptr,nv,type)
 
179
      elseif(buf(1:vol).eq.'outptr') then
 
180
        ierr=getscicosvars(11,ptr,nv,type)
 
181
      elseif(buf(1:vol).eq.'inplnk') then
 
182
        ierr=getscicosvars(12,ptr,nv,type)
 
183
      elseif(buf(1:vol).eq.'outlnk') then
 
184
        ierr=getscicosvars(13,ptr,nv,type)
 
185
      elseif(buf(1:vol).eq.'lnkptr') then
 
186
        ierr=getscicosvars(14,ptr,nv,type)
 
187
      else
 
188
         buf='Undefined field'
 
189
         call error(999)
 
190
         return
 
191
      endif
 
192
      if(ierr.ne.0) then
 
193
         buf='scicosim is not running'
 
194
         call error(999)
 
195
         return
 
196
      endif
 
197
      l=sadr(il1+4)
 
198
      if(type.eq.0) then
 
199
         call cint(nv,ptr,stk(l))
 
200
      else
 
201
         call cdouble(nv,ptr,stk(l))
 
202
      endif
 
203
      istk(il1)=1
 
204
      istk(il1+1)=nv
 
205
      istk(il1+2)=min(nv,1)
 
206
      istk(il1+3)=0
 
207
      lstk(top+1)=l+nv
 
208
      return
 
209
      end
 
210
 
 
211
 
 
212
      subroutine intsetscicosvars
 
213
      include '../stack.h'
 
214
      integer kfun
 
215
      common /curblk/ kfun
 
216
      integer vol,type,getscicosvars,ierr
 
217
      double precision ptr
 
218
      external getscicosvars
 
219
      integer iadr, sadr
 
220
      iadr(l)=l+l-1
 
221
      sadr(l)=(l/2)+1
 
222
 
 
223
      if(rhs.ne.2) then
 
224
         call error(39)
 
225
         return
 
226
      endif
 
227
      if (lhs .ne. 1) then
 
228
         call error(41)
 
229
         return
 
230
      endif
 
231
c     
 
232
      lw = lstk(top+1)
 
233
      il2=iadr(lstk(top))
 
234
      if(istk(il2).ne.1) then 
 
235
         err=2
 
236
         call error(53)
 
237
         return
 
238
      endif
 
239
      if(istk(il2+3).ne.0) then
 
240
         err=2
 
241
         call error(52)
 
242
         return
 
243
      endif
 
244
      nv2=istk(il2+1)*istk(il2+2)
 
245
      lv=sadr(il2+4)
 
246
      top=top-1
 
247
c
 
248
      il1=iadr(lstk(top))
 
249
      if(istk(il1+1)*istk(il1+2).ne.1) then
 
250
         err=1
 
251
         call error(36)
 
252
         return
 
253
      endif
 
254
c     
 
255
      mn1=1
 
256
      id1=il1+4
 
257
      l1=id1+mn1+1
 
258
      vol=istk(id1+mn1)-1
 
259
      call cvstr(vol,istk(l1),buf,1)
 
260
 
 
261
      if(buf(1:vol).eq.'x') then
 
262
        ierr=getscicosvars(1,ptr,nv,type)
 
263
      elseif(buf(1:vol).eq.'xptr') then
 
264
        ierr=getscicosvars(2,ptr,nv,type)
 
265
      elseif(buf(1:vol).eq.'z') then
 
266
        ierr=getscicosvars(3,ptr,nv,type)
 
267
      elseif(buf(1:vol).eq.'zptr') then
 
268
        ierr=getscicosvars(4,ptr,nv,type)
 
269
      elseif(buf(1:vol).eq.'rpar') then
 
270
        ierr=getscicosvars(5,ptr,nv,type)
 
271
      elseif(buf(1:vol).eq.'rpptr') then
 
272
        ierr=getscicosvars(6,ptr,nv,type)
 
273
      elseif(buf(1:vol).eq.'ipar') then
 
274
        ierr=getscicosvars(7,ptr,nv,type)
 
275
      elseif(buf(1:vol).eq.'ipptr') then
 
276
        ierr=getscicosvars(8,ptr,nv,type)
 
277
      elseif(buf(1:vol).eq.'outtb') then
 
278
        ierr=getscicosvars(9,ptr,nv,type)
 
279
      elseif(buf(1:vol).eq.'inpptr') then
 
280
        ierr=getscicosvars(10,ptr,nv,type)
 
281
      elseif(buf(1:vol).eq.'outptr') then
 
282
        ierr=getscicosvars(11,ptr,nv,type)
 
283
      elseif(buf(1:vol).eq.'inplnk') then
 
284
        ierr=getscicosvars(12,ptr,nv,type)
 
285
      elseif(buf(1:vol).eq.'outlnk') then
 
286
        ierr=getscicosvars(13,ptr,nv,type)
 
287
      elseif(buf(1:vol).eq.'lnkptr') then
 
288
        ierr=getscicosvars(14,ptr,nv,type)
 
289
      else
 
290
         buf='Undefined field'
 
291
         call error(999)
 
292
         return
 
293
      endif
 
294
      if(ierr.ne.0) then
 
295
         buf='scicosim is not running'
 
296
         call error(999)
 
297
         return
 
298
      endif
 
299
      if(nv.ne.nv2) then
 
300
         pstk(pt+1)=nv
 
301
         err=2
 
302
         call error(206)
 
303
         return
 
304
      endif
 
305
      if(type.eq.0) then
 
306
c     integer  
 
307
         call entier(nv,stk(lv),istk(iadr(lv)))
 
308
         call int2cint(nv,ptr,istk(iadr(lv)))
 
309
      else
 
310
         call dbl2cdbl(nv,ptr,stk(lv))
 
311
c     double
 
312
      endif
 
313
      il=iadr(lstk(top))
 
314
      istk(il)=0
 
315
      lstk(top+1)=lstk(top)+1
 
316
      return
 
317
      end
 
318
 
 
319
      subroutine intgetlabel
 
320
      include '../stack.h'
 
321
      integer iadr, sadr
 
322
      integer kfun
 
323
      integer getscilabel
 
324
      external getscilabel
 
325
      common /curblk/ kfun
 
326
c
 
327
      iadr(l)=l+l-1
 
328
      sadr(l)=(l/2)+1
 
329
 
 
330
      if(rhs.gt.1) then
 
331
         call error(39)
 
332
         return
 
333
      endif
 
334
      if (lhs .ne. 1) then
 
335
         call error(41)
 
336
         return
 
337
      endif
 
338
      if(rhs.eq.1) then
 
339
         il=iadr(lstk(top))
 
340
         if(istk(il).ne.1) then 
 
341
            err=1
 
342
            call error(54)
 
343
            return
 
344
         endif
 
345
         if(istk(il+1)*istk(il+2).ne.1) then
 
346
            err=1
 
347
            call error(36)
 
348
            return
 
349
         endif
 
350
         kf=stk(sadr(il+4))
 
351
         top=top-1
 
352
      else
 
353
         kf=kfun
 
354
      endif
 
355
 
 
356
c     
 
357
      lw = lstk(top+1)
 
358
      top=top+1
 
359
      il1=iadr(lstk(top))
 
360
      
 
361
      id1=il1+4
 
362
      l1=id1+2
 
363
      err=sadr(l1+50)-lstk(bot)
 
364
      if(err.gt.0) then
 
365
         call error(17)
 
366
         return
 
367
      endif
 
368
      ierr=getscilabel(kf,istk(l1),n)
 
369
      if(ierr.ne.0) then
 
370
         buf='scicosim is not running'
 
371
         call error(999)
 
372
         return
 
373
      endif
 
374
      istk(il1)=10
 
375
      istk(il1+1)=1
 
376
      istk(il1+2)=1
 
377
      istk(il1+3)=0
 
378
      istk(il1+4)=1
 
379
      istk(il1+5)=1+n
 
380
      lstk(top+1)=sadr(l1+n)
 
381
      return
 
382
      end