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 c
   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