← Back to branch summary

~ubuntu-branches/ubuntu/hoary/scilab/hoary

« back to all changes in this revision

Viewing changes to routines/int/i_m_i.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/i_m_i.f
 
1
      subroutine i_m_i
 
2
c     multiplication
 
3
      include '../stack.h'
 
4
      integer is1
 
5
      external memused
 
6
      integer memused
 
7
      integer iadr,sadr
 
8
c     
 
9
      iadr(l)=l+l-1
 
10
      sadr(l)=(l/2)+1
 
11
c     
 
12
      il2=iadr(lstk(top))
 
13
      if(istk(il2).lt.0) il2=iadr(istk(il2+1))
 
14
      m2=istk(il2+1)
 
15
      n2=istk(il2+2)
 
16
      it2=istk(il2+3)
 
17
      l2=il2+4
 
18
      mn2=m2*n2
 
19
      top=top-1
 
20
c     
 
21
      il1=iadr(lstk(top))
 
22
      if(istk(il1).lt.0) il1=iadr(istk(il1+1))
 
23
      m1=istk(il1+1)
 
24
      n1=istk(il1+2)
 
25
      it1=istk(il1+3)
 
26
      l1=il1+4
 
27
      mn1=m1*n1
 
28
c
 
29
      if(istk(il1).ne.8.or.istk(il2).ne.8) then
 
30
         if((istk(il1).eq.1.and.it1.eq.0).or.
 
31
     &        (istk(il2).eq.1.and.it2.eq.0) ) goto 10
 
32
         top=top+1
 
33
         fin=-fin
 
34
         return
 
35
      endif
 
36
 
 
37
      if(it1.ne.it2) then
 
38
         top=top+1
 
39
         fin=-fin
 
40
         return
 
41
      endif
 
42
 
 
43
 10   continue
 
44
      if (mn1 .eq. 1) then
 
45
c     .  cst*a
 
46
         is1 = istk(l1)
 
47
         if (m1.lt.0) then
 
48
            if(mn2.eq.1) then
 
49
c     .     eye*cst
 
50
               istk(il1+1)=m1
 
51
               istk(il1+2)=n1
 
52
               istk(il1+3)=it1
 
53
            else
 
54
               call error(14)
 
55
               return
 
56
            endif
 
57
         else
 
58
            istk(il1+1)=m2
 
59
            istk(il1+2)=n2
 
60
            istk(il1+3)=it1
 
61
         endif
 
62
         call gencopy(it1,1,istk(l1),1,is1,1)
 
63
         call gencopy(it1,mn2,istk(l2),1,istk(l1),1)
 
64
         call genscal(it1,mn2,is1,istk(l1),1)
 
65
         lstk(top+1)=sadr(l1+memused(it1,mn2))
 
66
      elseif (mn2 .eq. 1) then
 
67
c     .  a*cst
 
68
         if(m2.lt.0) then
 
69
            call error(14)
 
70
            return
 
71
         endif
 
72
         call genscal(it1,mn1,istk(l2),istk(l1),1)
 
73
      else
 
74
c     .  matrix*matrix
 
75
         if (n1 .ne. m2) then
 
76
            call error(10)
 
77
            return
 
78
         endif
 
79
         lr=l2+mn2
 
80
         err=sadr(lr+m1*n2)-lstk(bot)
 
81
         if(err.gt.0) then
 
82
            call error(17)
 
83
            return
 
84
         endif
 
85
         call genmmul(it1,istk(l1),m1,istk(l2),m2,istk(lr),m1,m1,n1,n2)
 
86
         call gencopy(it1,m1*n2,istk(lr),1,istk(l1),1)
 
87
         lstk(top+1)=sadr(l1+memused(it1,m1*n2))
 
88
         istk(il1+2)=n2
 
89
         istk(il1+3)=it1
 
90
 
 
91
      endif
 
92
 999  return
 
93
      end