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