← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/int/bitops.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/int/bitops.f
 
1
      subroutine bitops(op)
 
2
c     addition
 
3
      include '../stack.h'
 
4
      common /mtlbc/ mmode
 
5
      integer is1,top0,op
 
6
      external memused
 
7
      integer memused
 
8
      integer iadr,sadr
 
9
c     
 
10
      iadr(l)=l+l-1
 
11
      sadr(l)=(l/2)+1     
 
12
c
 
13
      il2=iadr(lstk(top))
 
14
      if(istk(il2).lt.0) il2=iadr(istk(il2+1))
 
15
      m2=istk(il2+1)
 
16
      n2=istk(il2+2)
 
17
      it2=istk(il2+3)
 
18
      l2=il2+4
 
19
      mn2=m2*n2
 
20
      top=top-1
 
21
c     
 
22
      il1=iadr(lstk(top))
 
23
      if(istk(il1).lt.0) il1=iadr(istk(il1+1))
 
24
      m1=istk(il1+1)
 
25
      n1=istk(il1+2)
 
26
      it1=istk(il1+3)
 
27
      l1=il1+4
 
28
      mn1=m1*n1
 
29
      if(it1.ne.it2.and.mn1.ne.0.and.mn2.ne.0) then
 
30
         top=top+1
 
31
         fin=-fin
 
32
         return
 
33
      endif
 
34
 
 
35
 
 
36
 07   continue
 
37
      if (mn1.eq.0) then
 
38
         call error(43)
 
39
         return
 
40
      elseif (mn2.eq.0) then
 
41
         call error(43)
 
42
         return
 
43
      elseif (m1 .lt. 0) then
 
44
c     .  eye+vector
 
45
         call error(43)
 
46
         return
 
47
      elseif (m2 .lt. 0) then
 
48
c     .  vector+eye
 
49
         call error(43)
 
50
         return
 
51
      elseif (mn2.eq.1) then
 
52
c     .  vector+const
 
53
         call genbitops(it1,op,mn1,istk(l2),0,istk(l1),1)
 
54
         lstk(top+1)=sadr(l1+memused(it1,mn1))
 
55
      elseif (mn1.eq.1) then
 
56
c     .  cst+vector
 
57
         call gencopy(it1,1,istk(l1),1,is1,1)
 
58
         call gencopy(it1,mn2,istk(l2),1,istk(l1),1)
 
59
         call genbitops(it1,op,mn2,is1,0,istk(l1),1)
 
60
         lstk(top+1)=sadr(l1+memused(it1,mn2))
 
61
 
 
62
         istk(il1+1)=m2
 
63
         istk(il1+2)=n2
 
64
      else
 
65
c     .  vector+vector
 
66
         if (m1 .ne. m2.or.n1 .ne. n2) then
 
67
            call error(8)
 
68
            return
 
69
         endif
 
70
         call genbitops(it1,op,mn1,istk(l2),1,istk(l1),1)
 
71
         lstk(top+1)=sadr(l1+memused(it1,mn1))
 
72
      endif
 
73
 999  return
 
74
      end
 
75