1      subroutine argos_space_cascad(ltran,lbbl)
2c
3      implicit none
4c
5#include "argos_space_common.fh"
6#include "global.fh"
7#include "mafdecls.fh"
8#include "msgids.fh"
9c
10      integer argos_space_btop
11      external argos_space_btop
12c
13      integer ltran(np,3),lbbl(mbbl,mbb2)
14c
15      integer i,j,k,ltemp
16      integer icell,jcell,iproc,jproc
17      logical lfirst
18c
19c     load balancing based on cascade box-list redistribution
20c     -------------------------------------------------------
21c
22      do 1 i=1,np
23      ltran(i,1)=ltran(i,1)-1
24      ltran(i,2)=ltran(i,2)-1
25      ltran(i,3)=-1
26      if(ltran(i,2).ge.0)
27     + ltran(i,3)=argos_space_btop(ltran(i,2),int_mb(i_iown))
28    1 continue
29c
30c     remove transfers involving double processors
31c
32      do 2 i=2,np
33      if(ltran(i,1).ge.0) then
34      iproc=argos_space_btop(ltran(i,1),int_mb(i_iown))
35      jproc=argos_space_btop(ltran(i,2),int_mb(i_iown))
36      do 3 j=1,i-1
37      if(argos_space_btop(ltran(j,1),int_mb(i_iown)).eq.jproc.or.
38     + argos_space_btop(ltran(j,2),int_mb(i_iown)).eq.jproc) then
39      ltran(i,1)=-1
40      ltran(i,2)=-1
41      goto 2
42      endif
43    3 continue
44      endif
45    2 continue
46c
47c     process the transfer list
48c
49      lfirst=.true.
50      do 4 i=1,np
51c
52      iproc=-1
53      jproc=-1
54      icell=ltran(i,1)
55      jcell=ltran(i,2)
56      if(icell.ge.0) then
57      iproc=argos_space_btop(icell,int_mb(i_iown))
58      jproc=argos_space_btop(jcell,int_mb(i_iown))
59      if(lfirst) then
60      lpipo=(iproc.eq.ipairt).and.(jproc.eq.ipairf)
61      ipairf=iproc
62      ipairt=jproc
63      lfirst=.false.
64      endif
65c
66c     remove pair
67c
68      if(iproc.eq.me) then
69      k=0
70      do 5 j=1,nbbl
71      if(lbbl(j,2).ne.jcell.or.lbbl(j,3).ne.icell) then
72      k=k+1
73      lbbl(k,1)=lbbl(j,1)
74      lbbl(k,2)=lbbl(j,2)
75      lbbl(k,3)=lbbl(j,3)
76      endif
77    5 continue
78      nbbl=k
79      endif
80c
81c     add pair
82c
83      if(jproc.eq.me) then
84      nbbl=nbbl+1
85      lbbl(nbbl,1)=iproc
86      lbbl(nbbl,2)=icell
87      lbbl(nbbl,3)=jcell
88      endif
89c
90      endif
91    4 continue
92c
93c     order the new box-box list
94c
95      nbbloc=0
96      do 6 i=1,nbbl-1
97      do 7 j=i+1,nbbl
98      if((lbbl(i,1).ne.me.and.lbbl(j,1).eq.me).or.
99     + (lbbl(i,1).gt.lbbl(j,1).and.lbbl(i,1).ne.me).or.
100     + (lbbl(i,1).eq.lbbl(j,1).and.lbbl(i,2).gt.lbbl(j,2)).or.
101     + (lbbl(i,1).eq.lbbl(j,1).and.lbbl(i,2).eq.lbbl(j,2).and.
102     + lbbl(i,3).gt.lbbl(j,3))) then
103      ltemp=lbbl(i,1)
104      lbbl(i,1)=lbbl(j,1)
105      lbbl(j,1)=ltemp
106      ltemp=lbbl(i,2)
107      lbbl(i,2)=lbbl(j,2)
108      lbbl(j,2)=ltemp
109      ltemp=lbbl(i,3)
110      lbbl(i,3)=lbbl(j,3)
111      lbbl(j,3)=ltemp
112      endif
113    7 continue
114      if(lbbl(i,1).eq.me) nbbloc=i
115    6 continue
116      if(lbbl(nbbl,1).eq.me) nbbloc=nbbl
117c
118      return
119      end
120c $Id$
121