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