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