Reorganization
[scilab.git] / scilab / modules / core / src / fortran / indxg.f
1       subroutine indxg(il,siz,ilr,mi,mx,lw,iopt1)
2 c!Purpose
3 c     Converts a scilab index variable to a vector of indices
4 c!Calling sequence
5 c     subroutine indxg(il,siz,ilr,mi,lw,iopt)
6 c     il    : beginning of a  a scilab variable structure. 
7 c     siz   : integer, matrix size, used for implicits index descriptions
8 c     ilr   : adress of first elment of resulting vector of indices in
9 c            istk
10 c     mi    : size of resulting vector of indices 
11 c     mx    : maximum value of resulting vector of indices
12 c     lw    : pointer to free space in stk (modified by execution)
13 c     iopt1 : flag with decimal form n+10*i
14 c            if n==0 null indices are accepted
15 c            else null indices are rejected
16 c            if i==0 
17 c               implicit indices ":" gives a vector istk(ilr)=1:siz, mi=siz,mx=siz
18 c            else 
19 c               implicit indice ":" gives mi=-1,mx=siz
20 c!
21
22 c     Copyright INRIA
23       include 'stack.h'
24       integer siz,iopt1,iopt
25       double precision e1,v(3)
26       integer iadr,sadr
27 c
28       iadr(l)=l+l-1
29       sadr(l)=(l/2)+1
30
31 c
32 c     
33       impl=iopt1/10
34       iopt=iopt1-10*impl
35 c
36       if(istk(il).lt.0) il=istk(il+1)
37
38       if(istk(il).eq.1.or.istk(il).eq.8) then
39 c     Index is a vector of scalars
40          m=istk(il+1)
41          n=istk(il+2)
42  
43          if(m.ge.1) then
44 c     .     general case
45             l=sadr(il+4)
46             ilr=iadr(lw)
47             lw=sadr(ilr+m*n)
48             err=lw-lstk(bot)
49             if(err.gt.0) then
50                call error(17)
51                return
52             endif
53             if (istk(il).eq.1) then
54                if(istk(il+3).ne.0) then 
55                   call error(21)
56                   return
57                endif
58                call entier(m*n,stk(l),istk(ilr))
59             else
60                call tpconv(istk(il+3),4,m*n,istk(il+4),1,istk(ilr),1)
61             endif
62             mi=m*n
63             mx=0
64             do 05 i=0,m*n-1
65                if(iopt.eq.1.and.istk(ilr+i).le.0) then
66                   call error(21)
67                   return
68                else
69                   mx=max(mx,istk(ilr+i))
70                endif
71  05         continue
72          elseif(m.eq.0) then
73 c     .     index is []
74             ilr=il
75             mi=0
76             mx=0
77          elseif(m.eq.-1) then
78 c     .     index is : 
79             ilr=iadr(lw)
80             if(impl.eq.0) then
81                if(siz.gt.0) then
82                   lw=sadr(ilr+siz)
83                   err=lw-lstk(bot)
84                   if(err.gt.0) then
85                      call error(17)
86                      return
87                   endif
88                   do 10 i=1,siz
89                      istk(ilr-1+i)=i
90  10               continue
91                endif
92                mi=siz
93             else
94                mi=-1
95             endif
96             mx=siz
97          endif
98       elseif (istk(il).eq.2) then
99 c     .  Index is a vector of polynomial
100          m=istk(il+1)
101          n=istk(il+2)
102          if(istk(il+3).ne.0) then 
103             call error(21)
104             return
105          endif
106          mi=m*n
107          l=sadr(il+9+mi)
108          lr=lw
109          ilr=iadr(lr)
110          lw=lr+mi
111          err=lw-lstk(bot)
112          if(err.gt.0) then
113             call error(17)
114             return
115          endif
116 c     .  evaluate it for siz
117          e1=siz
118          call ddmpev(stk(l),istk(il+8),1,e1,stk(lr),1,1,mi)
119          call entier(mi,stk(lr),istk(ilr))
120          lw=sadr(ilr+mi)
121          mx=0
122          do 15 i=0,mi-1
123             if(istk(ilr+i).le.0) then
124                call error(21)
125                return
126             else
127                mx=max(mx,istk(ilr+i))
128             endif
129  15      continue
130       elseif (istk(il).eq.129) then
131 c     .  Index is an implicit polynomial vector (beg:step:end)
132          e1=siz
133          l=sadr(il+12)
134          
135          call ddmpev(stk(l),istk(il+8),1,e1,v,1,1,3)
136          ideb=v(1)
137          ipas=v(2)
138          ifin=v(3)
139 c     sign used to avoid integer overflow
140          if(ipas.eq.0.or.(ifin-ideb)*sign(1,ipas).lt.0) then
141             mi=0
142             mx=0
143          else
144             if(ipas.lt.0.and.ifin.le.0.or.ipas.gt.0.and.ideb.le.0) then
145                call error(21)
146                return
147             endif
148             mi=int((abs(ifin-ideb)+1)/abs(ipas))
149
150             ilr=iadr(lw)
151             lw=sadr(ilr+mi+1)
152             err=lw-lstk(bot)
153             if(err.gt.0) then
154                call error(17)
155                return
156             endif
157             k=0
158             do 20 i=ideb,ifin,ipas
159                istk(ilr+k)=i
160                k=k+1
161  20         continue
162             mi=k
163             if(ipas.gt.0) then
164                mx=istk(ilr-1+mi)
165             else
166                mx=istk(ilr)
167             endif
168          endif
169       elseif (istk(il).eq.4) then
170 c     .  index is a boolean vector
171          m=istk(il+1)
172          n=istk(il+2)
173 c         if(m*n.ne.siz) then 
174 c            call error(21)
175 c            return
176 c         endif
177          ilr=iadr(lw)
178          lw=sadr(ilr+m*n)
179          err=lw-lstk(bot)
180          if(err.gt.0) then
181             call error(17)
182             return
183          endif
184          mi=0
185          do 30 i=1,m*n
186             if(istk(il+2+i).eq.1) then
187                istk(ilr+mi)=i
188                mi=mi+1
189             endif
190  30      continue
191          if(mi.eq.0) then
192             mx=0
193          else
194             mx=istk(ilr-1+mi)
195          endif
196          lw=sadr(ilr+mi)
197       elseif (istk(il).eq.6) then
198 c     .  index is a boolean vector
199          m=istk(il+1)
200          n=istk(il+2)
201          nel=istk(il+4)
202
203          ir=il+5
204          ic=ir+m
205          ilr=iadr(lw)
206          ilw=ilr+nel
207          mx=nel
208          mi=0
209          if (nel.gt.0) then
210             lw=sadr(ilw+nel)
211             err=lw-lstk(bot)
212             if(err.gt.0) then
213                call error(17)
214                return
215             endif
216             do 35 i=0,m-1
217                if(istk(ir).gt.0) then
218                   do 31 kk=0,istk(ir)-1
219                      istk(ilr+mi)=1+i+(istk(ic+kk)-1)*m
220                      mi=mi+1
221  31               continue
222                   ic=ic+istk(ir)
223                endif
224                ir=ir+1
225  35         continue
226             call isort1(istk(ilr),nel,istk(ilw),1)
227          endif
228          lw=sadr(ilr+nel)
229       else
230          call error(21)
231          return
232       endif
233       return
234       end
235
236
237       subroutine indxgc(il,siz,ilr,mi,mx,lw)
238 c!Purpose
239 c     Converts a scilab index variable to the complementary vector of indices
240 c!Calling sequence
241 c     subroutine indxg(il,siz,ilr,mi,lw)
242 c     il   : beginning of a scilab variable structure. 
243 c     siz  : integer, matrix size, used for implicits index descriptions
244 c     ilr  : adress of first elment of resulting vector of indices in
245 c            istk
246 c     mi   : size of resulting vector of indices 
247 c     mx   : maximum value of resulting vector of indices
248 c     lw   : pointer to free space in stk (modified by execution)
249 c!
250
251 *     modification by Bruno so as to use a faster algorithm (7 May 2002)
252
253       implicit none
254       include 'stack.h'
255       integer il, siz, ilr, mi, mx, lw
256
257       integer i, k, ilc
258       
259       integer l, iadr,sadr
260 c
261       iadr(l)=l+l-1
262       sadr(l)=(l/2)+1
263
264       call indxg(il,siz,ilr,mi,mx,lw,1)
265       if(err.gt.0) return
266       ilc=iadr(lw)
267       lw=sadr(ilc+siz)
268       err=lw-lstk(bot)
269       if(err.gt.0) then
270          call error(17)
271          return
272       endif
273       if(mi.eq.0) then
274          do i=1,siz
275             istk(ilc+i-1)=i
276          enddo
277          mx=istk(ilc+siz-1)
278          mi=siz
279       else
280
281 *     computes complement (part of the code modified by Bruno)
282 *
283 *     given 
284 *       1/ a "vector" w of mi indices stored from istk(ilr)
285 *          so that w=[istk(ilr), ....., istk(ilr+mi-1)] is this vector
286 *       2/ the "vector" v of indices v=[1,2,..., siz]
287 *
288 *     computes the vector v minus w
289 *     this new vector is stored from istk(ilc) and its final number of
290 *     components will be stored in mi
291
292          do i = 0, siz-1
293             istk(ilc+i) = 1
294          end do
295
296          do i = 0, mi-1
297             k = istk(ilr+i)
298             if (k .le. siz) istk(ilc+k-1) = 0
299          end do
300             
301          k = 0
302          do i = 1, siz
303             if (istk(ilc+i-1) .eq. 1) then
304                istk(ilc+k) = i
305                k = k+1
306             end if
307          end do
308          
309          mi = k
310          mx=istk(ilc-1+k)
311       endif
312       ilr=ilc
313       lw=sadr(ilr+mi)
314
315       return
316       end