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
|
subroutine nextj(id,j)
c ==============================================================
C extracts the jth occurence of x in do x=val and stores its value on top
C of the stack
c ==============================================================
include '../stack.h'
c
double precision dlamch
integer id(nsiz),j,vt,semi
c
integer ogettype,lr,lc,lr1,lc1
character*4 name
logical getmat,cremat,smatj,lmatj,getsmat,getilist,getpoly,pmatj
c
c
integer iadr
data semi/43/
c
iadr(l)=l+l-1
c
if (ddt .eq. 4) then
write(buf(1:4),'(i4)') j
call cvname(id,buf(5:4+nsiz*4),1)
call basout(io,wte,' nextj j:'//buf(1:4)//' var:'//
$ buf(5:4+nsiz*4))
endif
c
j = j + 1
if(comp(1).ne.0) return
top = top + 1
vt=ogettype(top-1)
goto (10,20,2,2,2,2,2,2,2,30,2,2,2,2,40) vt
2 err=vt
call error(76)
return
c--- matrices scalaires
10 if (.not.getmat("nextj",top-1,top-1,it,m,n,lr,lc)) return
if (m.eq.-3) then
C boucle implicite
if (.not.cremat("nextj",top,0,1,1,lr1,lc1)) return
stk(lr1) = stk(lr) + (j - 1)*stk(lr + 1)
if( stk(lr+1) * (stk(lr1) - stk(lr+2)) .gt. 0) then
if(abs(stk(lr1)-stk(lr+2)).gt.
$ abs(stk(lr+1)*dlamch('p'))) goto 50
endif
else
if (j .gt. n .or. m.eq.0) go to 50
if (.not.cremat("nextj",top,it,m,1,lr1,lc1)) return
call dcopy(m,stk(lr+(j-1)*m),1,stk(lr1),1)
if(it.eq.1) call dcopy(m,stk(lc+(j-1)*m),1,stk(lc1),1)
endif
goto 21
c-- matrices de polynomes
20 if (.not.getpoly("nextj",top-1,top-1,it,m,n,name,namel,ilp,lr,lc))
$ return
if(j.gt.n) goto 50
if (.not.pmatj("nextj",top,j)) return
goto 21
c--- chaines de caracteres
30 if (.not.getsmat("nextj",top-1,top-1,m,n,1,1,lr,nlj)) return
if ( j .gt.n) goto 50
if (.not.smatj("nextj",top,j)) return
goto 21
c---- listes
40 if (.not.getilist("nextj",top-1,top-1,m,j,ilj)) return
if(j.gt.m) goto 50
if (.not.lmatj("nextj",top,j)) return
goto 21
21 rhs = 0
sym=semi
call stackp(id,0)
return
50 top=top-1
il = iadr(lstk(top))
istk(il) = 0
rhs = 0
sym=semi
call stackp(id,0)
j = 0
return
end
|
