← Back to branch summary

~ubuntu-branches/ubuntu/raring/scilab/raring-proposed

« back to all changes in this revision

Viewing changes to modules/sparse/sci_gateway/fortran/sci_f_spmax.f

  • Committer: Package Import Robot
  • Author(s): Sylvestre Ledru
  • Date: 2012-08-30 14:42:38 UTC
  • mfrom: (1.4.7)
  • Revision ID: package-import@ubuntu.com-20120830144238-c1y2og7dbm7m9nig
Tags: 5.4.0-beta-3-1~exp1
* New upstream release
* Update the scirenderer dep
* Get ride of libjhdf5-java dependency

Show diffs side-by-side

added added

removed removed

Lines of Context:
modules/sparse/sci_gateway/fortran/sci_f_spmax.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-en.txt
9
 
      subroutine intspmax(fname,id)
10
 
      include 'stack.h'
11
 
      integer id(nsiz),top0
12
 
      character*(*) fname
13
 
      double precision tv
14
 
      integer iadr, sadr
15
 
 
16
 
      iadr(l)=l+l-1
17
 
      sadr(l)=(l/2)+1
18
 
 
19
 
      rhs = max(0,rhs)
20
 
      top0=top+1-rhs
21
 
 
22
 
      if (rhs .lt. 1) then
23
 
         call error(39)
24
 
         return
25
 
      endif
26
 
 
27
 
      lw = lstk(top+1)
28
 
      l0 = lstk(top+1-rhs)
29
 
      if (rhs.eq.1) then
30
 
         if (lhs .gt.2) then
31
 
            call error(41)
32
 
            return
33
 
         endif
34
 
         il1 = iadr(lstk(top))
35
 
         if (istk(il1) .ne. 5) then
36
 
            err=1
37
 
            call error(217)
38
 
            return
39
 
         endif
40
 
         m1=istk(il1+1)
41
 
         n1=istk(il1+2)
42
 
         it1=istk(il1+3)
43
 
         nel1=istk(il1+4)
44
 
         irc1=il1+5
45
 
         l1=sadr(irc1+m1+nel1)
46
 
         if(it1.ne.0) then
47
 
            err=1
48
 
            call error(52)
49
 
            return
50
 
         endif
51
 
         tv=0.0d0
52
 
         if(nel1.gt.0) then
53
 
            tv=stk(l1)
54
 
            im=0
55
 
            if(fin.eq.10) then
56
 
               do 60 i=0,nel1-1
57
 
                  if (stk(l1+i).gt.tv) then
58
 
                     tv=stk(l1+i)
59
 
                     im=i
60
 
                  endif
61
 
 60            continue
62
 
               if(tv.lt.0.0d0.and.nel1.lt.m1*n1) tv=0.0d0
63
 
            else
64
 
               do 61 i=0,nel1-1
65
 
                  if (stk(l1+i).lt.tv) then
66
 
                     tv=stk(l1+i)
67
 
                     im=i
68
 
                  endif
69
 
 61            continue
70
 
               if(tv.gt.0.0d0.and.nel1.lt.m1*n1) tv=0.0d0
71
 
            endif
72
 
         endif
73
 
c
74
 
         if(lhs.eq.2) then
75
 
            if (nel1.ne.0) then
76
 
               jm=istk(irc1+m1+im)
77
 
               im=im+1
78
 
               ii=0
79
 
               do 62 i=0,m1-1
80
 
                  ii=ii+istk(irc1+i)
81
 
                  if(ii.ge.im) goto 63
82
 
 62            continue
83
 
 63            im=i+1
84
 
            endif
85
 
         endif
86
 
c
87
 
         istk(il1)=1
88
 
         istk(il1+1)=1
89
 
         istk(il1+2)=1
90
 
         istk(il1+3)=0
91
 
         l=sadr(il1+4)
92
 
         stk(l)=tv
93
 
         lstk(top+1)=l+1
94
 
         if(lhs.eq.2) then
95
 
            top=top+1
96
 
            il2=iadr(lstk(top))
97
 
            err=lstk(top)+4-lstk(bot)
98
 
            if(err.gt.0) then
99
 
               call error(17)
100
 
               return
101
 
            endif
102
 
            istk(il2)=1
103
 
            l=sadr(il2+4)
104
 
            istk(il2+3)=0
105
 
            if (nel1.ne.0) then
106
 
               istk(il2+1)=1
107
 
               istk(il2+2)=1
108
 
               stk(l)=im+(jm-1)*m1
109
 
               lstk(top+1)=l+1
110
 
            else
111
 
               istk(il2+1)=0
112
 
               istk(il2+2)=0
113
 
               lstk(top+1)=l+1
114
 
            endif
115
 
         endif
116
 
         return
117
 
      endif
118
 
c     
119
 
c     checking variable sp2 (number 2)
120
 
c
121
 
      if (lhs .ne. 1) then
122
 
         call error(41)
123
 
         return
124
 
      endif
125
 
      do 65 i=1,rhs-1
126
 
         il2 = iadr(lstk(top))
127
 
         if (istk(il2) .ne. 5) then
128
 
            err=2
129
 
            call error(217)
130
 
            return
131
 
         endif
132
 
 
133
 
         m2=istk(il2+1)
134
 
         n2=istk(il2+2)
135
 
         it2=istk(il2+3)
136
 
         nel2=istk(il2+4)
137
 
         irc2=il2+5
138
 
         if(it2.ne.0) then
139
 
            err=2
140
 
            call error(52)
141
 
            return
142
 
         endif
143
 
         l2=sadr(irc2+m2+nel2)
144
 
c     
145
 
c     checking variable sp1 (number 1)
146
 
c     
147
 
         top=top-1
148
 
         il1 = iadr(lstk(top))
149
 
         if (istk(il1) .ne. 5) then
150
 
            err=1
151
 
            call error(217)
152
 
            return
153
 
         endif
154
 
         m1=istk(il1+1)
155
 
         n1=istk(il1+2)
156
 
         it1=istk(il1+3)
157
 
         nel1=istk(il1+4)
158
 
         irc1=il1+5
159
 
         l1=sadr(irc1+m1+nel1)
160
 
 
161
 
         if(it1.ne.0) then
162
 
            err=1
163
 
            call error(52)
164
 
            return
165
 
         endif
166
 
         if(m1.ne.m2.or.n1.ne.n2) then
167
 
            call error(60)
168
 
            return
169
 
         endif
170
 
         irc=iadr(lw)
171
 
         nelmx=(iadr(lstk(bot))-irc-m1-10)/3
172
 
         lc=sadr(irc+m1+nelmx)
173
 
         lw=lc+nelmx
174
 
         err=lw-lstk(bot)
175
 
         if(err.gt.0) then
176
 
            call error(17)
177
 
            return
178
 
         endif  
179
 
         nel=nelmx
180
 
         if(fname.eq.'max') then
181
 
            call dspmax(m1,n1,stk(l1),nel1,istk(irc1),stk(l2),nel2,
182
 
     $           istk(irc2),stk(lc),nel,istk(irc),ierr)
183
 
         else
184
 
            call dspmin(m1,n1,stk(l1),nel1,istk(irc1),stk(l2),nel2,
185
 
     $           istk(irc2),stk(lc),nel,istk(irc),ierr)
186
 
         endif
187
 
         if(ierr.ne.0) then
188
 
            call error(17)
189
 
            return
190
 
         endif
191
 
         istk(il1+3)=0
192
 
         istk(il1+4)=nel
193
 
         call icopy(m1+nel,istk(irc),1,istk(irc1),1)
194
 
         l1=sadr(irc1+m1+nel)
195
 
         call unsfdcopy(nel,stk(lc),1,stk(l1),1)
196
 
         lstk(top+1)=l1+nel
197
 
 65   continue
198
 
      return
199
 
      end
200
 
c                       ======================================