← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/int/i_f_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_f_i.f
 
1
      subroutine i_f_i
 
2
c     concatenation [a;b]
 
3
      include '../stack.h'
 
4
      common /mtlbc/ mmode
 
5
      integer top0
 
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
      lw=lstk(top+1)
 
14
      top0=top
 
15
c
 
16
      il2=iadr(lstk(top))
 
17
      if(istk(il2).lt.0) il2=iadr(istk(il2+1))
 
18
      m2=istk(il2+1)
 
19
      n2=istk(il2+2)
 
20
      it2=istk(il2+3)
 
21
      l2=il2+4
 
22
      mn2=m2*n2
 
23
      top=top-1
 
24
c     
 
25
      il1=iadr(lstk(top))
 
26
      if(istk(il1).lt.0) il1=iadr(istk(il1+1))
 
27
      m1=istk(il1+1)
 
28
      n1=istk(il1+2)
 
29
      it1=istk(il1+3)
 
30
      l1=il1+4
 
31
      mn1=m1*n1
 
32
 
 
33
      if((istk(il1).ne.istk(il2).or.it1.ne.it2).and.
 
34
     $     mn1.ne.0.and.mn2.ne.0) then   
 
35
         top=top0
 
36
         fin=-fin
 
37
         return
 
38
      endif
 
39
 
 
40
 76   if(n1.lt.0.or.n2.lt.0) then
 
41
         call error(14)
 
42
         return
 
43
      elseif(n2.eq.0) then
 
44
c     .  [a;[]]
 
45
         return
 
46
      elseif(n1.eq.0)then
 
47
c     .  [[];b]
 
48
         call unsfdcopy(lstk(top+2)-lstk(top+1),stk(lstk(top+1))
 
49
     $        ,1,stk(lstk(top)),1)
 
50
         lstk(top+1)=lstk(top)+lstk(top+2)-lstk(top+1)
 
51
         return
 
52
      elseif(n1.ne.n2) then
 
53
         call error(6)
 
54
         return
 
55
      endif
 
56
      m=m1+m2
 
57
      mn=m*n1
 
58
 
 
59
      lw1=max(iadr(lw),l1+memused(it1,mn)+1)
 
60
      lw2=lw1+memused(it1,mn1)+1
 
61
      err=sadr(lw2+memused(it1,mn2))-lstk(bot)
 
62
      if(err.gt.0) then
 
63
         call error(17)
 
64
         return
 
65
      endif
 
66
      call gencopy(it1,mn2,istk(l2),1,istk(lw2),1)
 
67
      call gencopy(it1,mn1,istk(l1),1,istk(lw1),1)
 
68
 
 
69
      call genconcatcol(it1,istk(lw1),m1,n1,istk(lw2),m2,n2,istk(l1))
 
70
      lstk(top+1)=sadr(il1+4+memused(it1,mn))
 
71
 
 
72
      istk(il1+1)=m
 
73
      istk(il1+2)=n1
 
74
      istk(il1+3)=it1
 
75
 
 
76
 999  return
 
77
      end