← Back to branch summary

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

« back to all changes in this revision

Viewing changes to routines/signal/datatf.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2005-01-09 22:58:21 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20050109225821-473xr8vhgugxxx5j
Tags: 3.0-12
http://bugs.debian.org/255869
changed configure.in to build scilab's own malloc.o, closes: #255869

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/signal/datatf.f
1
 
      subroutine datatf
2
 
c     Copyright INRIA
3
 
c ================================== ( Inria    ) =============
4
 
c     manipulation de donnees
5
 
c =============================================================
6
 
      include '../stack.h'
7
 
c
8
 
      common /tg02bd/ knot
9
 
      integer lr(4),per,iadr,sadr
10
 
      double precision vals(4)
11
 
      logical period
12
 
      data per/25/
13
 
c
14
 
c
15
 
c     fonction  spline inte
16
 
c                 1     2
17
 
c
18
 
c
19
 
      iadr(l)=l+l-1
20
 
      sadr(l)=(l/2)+1
21
 
c
22
 
      if (ddt .eq. 4) then
23
 
         write(buf(1:4),'(i4)') fin
24
 
         call basout(io,wte,' datatf '//buf(1:4))
25
 
      endif
26
 
      if(rhs.le.0) then
27
 
                call error(39)
28
 
                return
29
 
      endif
30
 
      goto (10,20) fin
31
 
c
32
 
c spline
33
 
c
34
 
   10 if(rhs.gt.3) then
35
 
         call error(39)
36
 
         return
37
 
      endif
38
 
      period=.false.
39
 
      if(rhs.eq.3) then
40
 
        il=iadr(lstk(top))
41
 
        if(istk(il).ne.10) then
42
 
           err=rhs
43
 
           call error(55)
44
 
           return
45
 
        endif
46
 
        if(istk(il+1)*istk(il+2).ne.1) then
47
 
           err=rhs
48
 
           call error(89)
49
 
           return
50
 
        endif
51
 
        if(abs(istk(il+6)).eq.per) period=.true.
52
 
        top=top-1
53
 
      endif
54
 
      il=iadr(lstk(top))
55
 
      if(istk(il).ne.1) then
56
 
         err=2
57
 
         call error(53)
58
 
         return
59
 
      endif
60
 
      if(istk(il+3).ne.0) then
61
 
       err=2
62
 
       call error(52)
63
 
       return
64
 
      endif
65
 
      nf=istk(il+1)*istk(il+2)
66
 
      lf=sadr(il+4)
67
 
      top=top-1
68
 
      il=iadr(lstk(top))
69
 
      if(istk(il).ne.1) then
70
 
         err=1
71
 
         call error(53)
72
 
         return
73
 
      endif
74
 
      if(istk(il+3).ne.0) then
75
 
         err=1
76
 
         call error(52)
77
 
         return
78
 
      endif
79
 
      nx=istk(il+1)*istk(il+2)
80
 
      n=min(nf,nx)
81
 
      lx=sadr(il+4)
82
 
c
83
 
      ld=lf+n
84
 
      lw=ld+n
85
 
      err=lw+3*n-lstk(bot)
86
 
      if(err.gt.0) then
87
 
         call error(17)
88
 
         return
89
 
      endif
90
 
      if(.not.period) then
91
 
         call dspln(n,stk(lx),stk(lf),stk(ld),stk(lw),err)
92
 
         if(err.eq.1) then
93
 
            err=1
94
 
            call error(99)
95
 
            return
96
 
         endif
97
 
      else
98
 
         call dpspln(n,stk(lx),stk(lf),stk(ld),stk(lw),err)
99
 
         if(err.eq.1) then
100
 
            err=1
101
 
            call error(99)
102
 
            return
103
 
         endif
104
 
         if(err.eq.2) then
105
 
            err=2
106
 
            call error(101)
107
 
            return
108
 
         endif
109
 
      endif
110
 
      call unsfdcopy(n,stk(ld),1,stk(lx),1)
111
 
      goto 99
112
 
c
113
 
c
114
 
c interpolation
115
 
c
116
 
   20 if(rhs.ne.4) then
117
 
         call error(39)
118
 
         return
119
 
      endif
120
 
      lw=lstk(top+1)
121
 
      il=iadr(lstk(top))
122
 
      if(istk(il).ne.1) then
123
 
         err=4
124
 
         call error(53)
125
 
         return
126
 
      endif
127
 
      if(istk(il+3).ne.0) then
128
 
         err=4
129
 
         call error(52)
130
 
         return
131
 
      endif
132
 
      n=istk(il+1)*istk(il+2)
133
 
      ld=sadr(il+4)
134
 
      top=top-1
135
 
      il=iadr(lstk(top))
136
 
      if(istk(il).ne.1) then
137
 
         err=3
138
 
         call error(53)
139
 
         return
140
 
      endif
141
 
      if(istk(il+3).ne.0) then
142
 
         err=3
143
 
         call error(52)
144
 
         return
145
 
      endif
146
 
      n=istk(il+1)*istk(il+2)
147
 
      lf=sadr(il+4)
148
 
      top=top-1
149
 
      il=iadr(lstk(top))
150
 
      if(istk(il).ne.1) then
151
 
         err=2
152
 
         call error(53)
153
 
         return
154
 
      endif
155
 
      if(istk(il+3).ne.0) then
156
 
         err=2
157
 
         call error(52)
158
 
         return
159
 
      endif
160
 
      n=istk(il+1)*istk(il+2)
161
 
      lx=sadr(il+4)
162
 
      top=top-1
163
 
      il=iadr(lstk(top))
164
 
      if(istk(il).ne.1) then
165
 
         err=1
166
 
         call error(53)
167
 
         return
168
 
      endif
169
 
      if(istk(il+3).ne.0) then
170
 
         err=1
171
 
         call error(52)
172
 
         return
173
 
      endif
174
 
      m0=istk(il+1)
175
 
      n0=istk(il+2)
176
 
      mn0=m0*n0
177
 
      lx0=sadr(il+4)
178
 
      lr(1)=lx0
179
 
      if(lhs.ge.2) then
180
 
            err=lw+(lhs-1)*mn0-lstk(bot)
181
 
            if(err.gt.0) then
182
 
               call error(17)
183
 
               return
184
 
            endif
185
 
            do 21 k=2,lhs
186
 
            lr(k)=lw
187
 
   21       lw=lw+mn0
188
 
      endif
189
 
      mode=-1
190
 
      do 23 i=1,mn0
191
 
      call tg02ad(mode,n,stk(lx),stk(lf),stk(ld),stk(lx0+i-1),
192
 
     1            vals)
193
 
      mode=1
194
 
      do 22 k=1,lhs
195
 
   22 stk(lr(k)-1+i)=vals(k)
196
 
      mode=+1
197
 
   23 continue
198
 
      if(lhs.eq.1) goto 99
199
 
      do 24 k=2,lhs
200
 
      top=top+1
201
 
      il=iadr(lstk(top))
202
 
      istk(il)=1
203
 
      istk(il+1)=n0
204
 
      istk(il+2)=m0
205
 
      istk(il+3)=0
206
 
      l=sadr(il+4)
207
 
      call unsfdcopy(mn0,stk(lr(k)),1,stk(l),1)
208
 
      lstk(top+1)=l+mn0
209
 
   24 continue
210
 
      goto 99
211
 
c
212
 
   99 continue
213
 
      return
214
 
      end