1      logical function argos_prep_excl(l3rd,m3rd,n3rd,lbnd,mbnd,nbnd,
2     + lang,mang,nang,lexc,mexc,nexc,nval,ival,ndx,catt,matt,
3     + lats,nparms,mats,latm,matm,natm,lupdat)
4c
5c $Id$
6c
7      implicit none
8c
9      integer m3rd,n3rd,mbnd,nbnd,mang,nang,mexc,nexc
10      integer matt,mats,matm,natm
11      integer l3rd(2,m3rd),lbnd(4,mbnd),lang(5,mang),lexc(2,mexc)
12      integer nval,nparms
13      integer ival(nval),ndx(nval)
14      character*6 catt(2,matt)
15      integer lats(nparms,mats)
16      integer latm(11,matm)
17      logical lupdat
18c
19      integer i,j,k,l,in,jn,ln,itmp,ir
20c
21      if(n3rd.gt.mexc) call md_abort('increase mexc',9999)
22      do 1 i=1,n3rd
23      lexc(1,i)=l3rd(1,i)
24      lexc(2,i)=l3rd(2,i)
25    1 continue
26      nexc=n3rd
27c
28      do 2 i=1,nbnd
29      nexc=nexc+1
30      if(nexc.gt.mexc) call md_abort('increase mexc',9999)
31      lexc(1,nexc)=lbnd(1,i)
32      lexc(2,nexc)=lbnd(2,i)
33    2 continue
34      do 3 i=1,nang
35      nexc=nexc+1
36      if(nexc.gt.mexc) call md_abort('increase mexc',9999)
37      lexc(1,nexc)=min(lang(1,i),lang(3,i))
38      lexc(2,nexc)=max(lang(1,i),lang(3,i))
39    3 continue
40c
41      if(lupdat.and.nparms.eq.3) then
42      do 4 i=1,natm-1
43      if(catt(1,lats(2,latm(3,i)))(6:6).eq.'D') then
44      do 5 j=i+1,natm
45      if(catt(1,lats(3,latm(3,j)))(6:6).eq.'D') then
46      nexc=nexc+1
47      if(nexc.gt.mexc) call md_abort('increase mexc',9999)
48      lexc(1,nexc)=i
49      lexc(2,nexc)=j
50      write(*,'(a,2i5)') 'Excluding ',i,j
51      endif
52    5 continue
53      elseif(catt(1,lats(3,latm(3,i)))(6:6).eq.'D') then
54      do 6 j=i+1,natm
55      if(catt(1,lats(2,latm(3,j)))(6:6).eq.'D') then
56      nexc=nexc+1
57      if(nexc.gt.mexc) call md_abort('increase mexc',9999)
58      lexc(1,nexc)=i
59      lexc(2,nexc)=j
60      write(*,'(a,2i5)') 'Excluding ',i,j
61      endif
62    6 continue
63      endif
64    4 continue
65      endif
66c
67      if(nexc.gt.1) then
68      do 7 i=1,nexc
69      ndx(i)=i
70    7 continue
71      ln=nexc/2+1
72      ir=nexc
73    8 continue
74      if(ln.gt.1) then
75      ln=ln-1
76      itmp=ndx(ln)
77      else
78      itmp=ndx(ir)
79      ndx(ir)=ndx(1)
80      ir=ir-1
81      if(ir.eq.1) then
82      ndx(1)=itmp
83      goto 9
84      endif
85      endif
86      in=ln
87      jn=ln+ln
88   10 continue
89      if(jn.le.ir) then
90      if(jn.lt.ir) then
91      if(lexc(1,ndx(jn)).gt.lexc(1,ndx(jn+1)).or.
92     + (lexc(1,ndx(jn)).eq.lexc(1,ndx(jn+1)).and.
93     + lexc(2,ndx(jn)).gt.lexc(2,ndx(jn+1)))) then
94      else
95      jn=jn+1
96      endif
97      endif
98      if(lexc(1,itmp).gt.lexc(1,ndx(jn)).or.
99     + (lexc(1,itmp).eq.lexc(1,ndx(jn)).and.
100     + lexc(2,itmp).gt.lexc(2,ndx(jn)))) then
101      jn=ir+1
102      else
103      ndx(in)=ndx(jn)
104      in=jn
105      jn=jn+jn
106      endif
107      goto 10
108      endif
109      ndx(in)=itmp
110      goto 8
111    9 continue
112c
113      do 11 k=1,2
114      do 12 i=1,nexc
115      ival(i)=lexc(k,i)
116   12 continue
117      do 13 i=1,nexc
118      lexc(k,i)=ival(ndx(i))
119   13 continue
120   11 continue
121      endif
122c
123      if(nexc.gt.1) then
124      l=nexc
125      nexc=1
126      do 14 i=2,l
127      if(lexc(1,i).ne.lexc(1,nexc).or.lexc(2,i).ne.lexc(2,nexc)) then
128      nexc=nexc+1
129      lexc(1,nexc)=lexc(1,i)
130      lexc(2,nexc)=lexc(2,i)
131      endif
132   14 continue
133      endif
134c
135      argos_prep_excl=.true.
136      return
137      end
138