1c     Scicos
2c
3c     Copyright (C) INRIA - METALAU Project <scicos@inria.fr>
4c
5c     This program is free software; you can redistribute it and/or modify
6c     it under the terms of the GNU General Public License as published by
7c     the Free Software Foundation; either version 2 of the License, or
8c     (at your option) any later version.
9c
10c     This program is distributed in the hope that it will be useful,
11c     but WITHOUT ANY WARRANTY; without even the implied warranty of
12c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13c     GNU General Public License for more details.
14c
15c     You should have received a copy of the GNU General Public License
16c     along with this program; if not, write to the Free Software
17c     Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
18c
19c     See the file ./license.txt
20c
21
22      subroutine ftree3(vec,nb,deput,typl,bexe,boptr,
23c     Copyright INRIA
24     $     blnk,blptr,kk,ord,nord,ok)
25c     make sure nb > 0
26      integer vec(*),nb,deput(*),typl(*),bexe(*),boptr(*)
27      integer blnk(*),blptr(*),ord(*),nord,ok,kk(*),fini
28c
29
30      ok=1
31      do 10 i=1,nb
32         if ( (vec(i).eq.0).and.(typl(i).eq.1) )   vec(i)=1
33 10   continue
34
35      do 150 j=1,nb+2
36         fini=1
37         if (j.eq.(nb+2)) then
38            ok=0
39            nord=0
40            return
41         endif
42
43         do 100 i=1,nb
44            if ((vec(i).gt.-1).AND.(typl(i).ne.-1)) then
45               if (typl(i).eq.1) then
46                  nkk=boptr(i+1)-boptr(i)
47                  if (nkk.ne.0) then
48                     do 50 m=1,nkk
49                        ii=bexe(m+boptr(i)-1)
50                        if (typl(ii).eq.1) then
51                           if (vec(ii).lt.(vec(i)+2)) then
52                              fini=0
53                              vec(ii)=vec(i)+2
54                           endif
55                        else
56                           if (vec(ii).lt.(vec(i)+1)) then
57                              fini=0
58                              vec(ii)=vec(i)+1
59                           endif
60                        endif
61 50                  continue
62                  endif
63               else
64                  nkk=blptr(i+1)-blptr(i)
65                  if (nkk.ne.0) then
66                     do 60 m=1,nkk
67                        ii=blnk(m+blptr(i)-1)
68                        if ((vec(ii).gt.-1).AND.((deput(ii).eq.1)
69     $                       .OR.(typl(ii).eq.1))) then
70                           if (vec(ii).lt.vec(i)) then
71                              fini=0
72                              vec(ii)=vec(i)
73                           endif
74                        endif
75 60                  continue
76                  endif
77               endif
78            endif
79 100     continue
80         if (fini.eq.1)     goto 200
81c          write(6,'(      "vec"  ,e10.3,"flag=",i1           )') t,flag
82 150  continue
83C     loop J finished
84 200  continue
85
86      do 202 m=1,nb
87         vec(m)=-vec(m)
88 202  continue
89
90      call isort(vec,nb,ord)
91      do 300 m=1,nb
92         if (vec(m).lt.1) then
93            if (m.eq.1) then
94               nord=nb
95               return
96            else
97               nord=nb-m+1
98               do 250 mm=1,nord
99                  ord(mm)=ord(mm+nb-nord)
100 250           continue
101               return
102            endif
103         endif
104 300  continue
105      nord=0
106      return
107      end
108
109