Fortran is not C
[scilab.git] / scilab / modules / elementary_functions / sci_gateway / fortran / sci_f_dsearch.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA
3
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.1-en.txt
9 c     -------------------------------
10 c
11       subroutine intdsearch(id)
12 *
13 *     interface for dsearch (Bruno le 10/12/2001)
14 *
15 *       [ind , occ, info] = dsearch(X, val [, ch])
16 *        
17 *       X and val must be real vectors (says of length m for X and n for val ), 
18 *       if ch is not present then ch = 'c'  (dsearch on "intervals")
19 *       ch must be 'd' or 'c'
20 *
21 *       ind is a vector with the same format than X
22 *       occ is a vector with the same format than val (but with n-1
23 *           components in the case ch='c')
24 *       info is a scalar
25 *
26       implicit none
27
28       INCLUDE 'stack.h'
29
30       integer id(nsiz)
31
32 c     EXTERNAL SUBROUTINES
33       external  dsearchc, dsearchd
34
35 c     EXTERNAL API FUNCTIONS
36       logical  checkrhs, checklhs, getsmat, getrvect, cremat, getrmat
37       external checkrhs, checklhs, getsmat, getrvect, cremat, getrmat
38
39 c     LOCAL VAR
40       integer topk, topl, il
41       integer mX, nX, lX, mval, nval, lval, mch, nch, lch, nlch
42       integer lind, mocc, nocc, locc, linfo, lc, j
43       character*1 ch
44       character*9 fname
45
46 c     STATEMENT FUNC
47       integer l, iadr
48       iadr(l)=l+l-1
49
50 c     TEXT
51       fname = 'dsearch'
52       topk=top
53       rhs=max(0,rhs)
54
55       if (.not.checkrhs(fname,2,3)) return
56       if (.not.checklhs(fname,1,3)) return
57
58 *     get ch
59       if (rhs .eq. 3) then
60          if( .not. getsmat(fname,topk,top,mch,nch,1,1,lch,nlch)) return
61          top = top - 1
62          call cvstr(1,istk(lch),ch,1)
63       else
64          ch = 'c'
65       endif
66       if (ch.ne.'c' .and. ch.ne.'d') then
67          buf=fname//' : unknown char specifier (must be ''c'' or ''d'')'
68          call error(999)
69          return
70       endif
71
72 c     get val
73       il = iadr(lstk(top))
74       if (istk(il) < 0) then
75         il = iadr(istk(il + 1))
76       endif
77       if (istk(il) .ne. 1) then
78         err = 2
79         call error(202)
80         return
81       endif
82       if( .not. getrvect(fname, topk, top, mval, nval, lval) ) return
83       if (ch.eq.'d') then
84          if (mval*nval.lt.1) then
85             buf=fname//' : argument 2 must not be an empty vector'
86             call error(999)
87             return
88          endif
89          mocc = mval
90          nocc = nval
91       else    ! case ch='c'
92          if (mval*nval.lt.2) then
93             buf=fname//' : in the interval case, argument 2 must be'
94      $               //' a vector with length > 1'
95             call error(999)
96             return
97          endif
98          if (mval .eq. 1) then 
99             mocc = 1
100             nocc = nval - 1
101          else
102             mocc = mval - 1
103             nocc = nval
104          endif
105       endif
106 *     verif that val is in strict increasing order
107       do j = 1, mval*nval-1
108          if (.not. stk(lval+j-1) .lt. stk(lval+j)) then  ! cette forme permet de detecter les nans
109             buf=fname//' : the array s (arg 2) is not well ordered'
110             call error(999)
111             return
112          endif
113       enddo
114       top = top - 1
115       
116 c     get X
117       il = iadr(lstk(top))
118       if (istk(il) < 0) then
119         il = iadr(istk(il + 1))
120       endif
121       if (istk(il) .ne. 1) then
122         err = 1
123         call error(202)
124         return
125       endif
126       if( .not. getrmat(fname, topk, top, mX, nX, lX) ) return
127
128 c     reserve space for ind
129       if (.not.cremat(fname, topk+1, 0, mX, nX, lind, lc)) return
130
131 c     reserve space for occ
132       if (.not.cremat(fname, topk+2, 0, mocc, nocc, locc, lc)) return
133
134 c     reserve space for info
135       if (.not.cremat(fname, topk+3, 0, 1, 1, linfo, lc)) return
136
137       if (mX.eq.0.or.nX.eq.0) then
138          stk(linfo)=0
139          call dset(mocc*nocc,0.0D0,stk(locc),1)
140       else
141
142 c     go on for the computation
143          if ( ch .eq. 'c') then
144             call dsearchc(stk(lX), mX*nX, stk(lval), mval*nval-1,
145      $           stk(lind), stk(locc), stk(linfo))
146          else 
147             call dsearchd(stk(lX), mX*nX, stk(lval), mval*nval, stk(lind
148      $           ),stk(locc), stk(linfo))
149          endif
150
151 c     int2db ... (normalement ca doit passer avec -1 sans copie
152 C     supplementaire)
153          call int2db(mX*nX,     istk(iadr(lind)), -1, stk(lind), -1) 
154          call int2db(mocc*nocc, istk(iadr(locc)), -1, stk(locc), -1) 
155          call int2db(1,     istk(iadr(linfo)),-1, stk(linfo),-1) 
156       endif
157 *     copie en "haut" 
158       topl = topk - rhs
159       if(lhs .ge. 1) then
160          call copyobj(fname,topk+1,topl+1)
161       endif
162       if(lhs .ge. 2) then
163          call copyobj(fname,topk+2,topl+2)
164       endif
165       if(lhs .ge. 3) then
166          call copyobj(fname,topk+3,topl+3)
167       endif
168       top=topl+lhs
169       return 
170       end
171 c     -------------------------------