1 : C NOEPR2 SOURCE PV 13/11/29 21:15:05 7872 2 : C**************************************************************************** 3 : C**************************************************************************** 4 : C*************NOEPERI ..NOEuds PERIpheriques********************************* 5 : C**************************************************************************** 6 : C**************************************************************************** 7 : 8 : C NOEPERI part de PIVOT,lui associe l=1, associe l=l+1 a ses voisins directs, 9 : C repart des voisins directs pour associer un l a leur voisins.... 10 : C LONG=max(l). 11 : C NRELONG(I)=l ,NOELON contient les noeuds tels que l=LONG. 12 : * noepr2 rend en prime la distance a la frontiere, sa taille et le 13 : * desequilibre des domaines 14 : * si nbtot n'est pas nul, noepr2 s'arrete des qu'il a trouve la 15 : * frontiere (il a remplis nbtot/2) pts. nrelong est alors remis a 16 : * zero 17 : 18 : SUBROUTINE NOEPR2(IADJ,JADJC,PIVOT,NRELONG,NOELON,isens,dimlon, 19 : > MASQ,NODES,IPOS,NBTOT,lfront,lfron,londim,fcout,lpiv) 20 : IMPLICIT INTEGER(I-N) 21 : IMPLICIT REAL*8 (A-H,O-Z) 22 : 23 : integer iadj(1),jadjc(1) 24 : integer pivot(lpiv) 25 : 26 : INTEGER LONG,DIMLON,Y,X,dimini,diminj 27 : integer nrelong(1),noelon(1) 28 : 29 : integer ipos(1) 30 : logical masq(1) 31 : integer londim(1) 32 : INTEGER NODES 33 : 34 : INTEGER DIML2 35 : LOGICAL bool2 36 : 37 : MDOMN=IPOS(PIVOT(1)+NODES) 38 : DIMLON=0 39 : DIML2=0 40 : LONG=1 41 : do 10 i=1,lpiv 42 : if (pivot(i).le.0) goto 10 43 : if (ipos(pivot(i)+nodes).ne.mdomn) goto 10 44 : do j=1,diml2 45 : if (pivot(i).eq.noelon(j)) then 46 : goto 10 47 : endif 48 : enddo 49 : diml2=diml2+1 50 : noelon(diml2)=pivot(i) 51 : nrelong(pivot(i))=long*2 52 : 10 continue 53 : londim(1)=diml2 54 : mode=1 55 : if (nbtot.eq.0) mode=2 56 : if (nbtot.eq.-1) mode=3 57 : 58 : 20 CONTINUE 59 : DIMINI=DIMLON+1 60 : DIMLON=DIML2 61 : LONG=LONG+1 62 : DO 30 I=DIMINI,DIMLON 63 : X=NOELON(I) 64 : BOOL2=.false. 65 : DO 40 J=IADJ(X),IADJ(X+1)-1 66 : Y=JADJC(J) 67 : if (y.eq.0) goto 40 68 : C Y: voisin d'un noeud de profondeur LONG-1. 69 : IF(NRELONG(Y).EQ.LONG*2) then 70 : BOOL2=.true. 71 : goto 40 72 : elseif (NRELONG(Y).ne.0) then 73 : goto 40 74 : elseif (MDOMN.EQ.IPOS(Y+NODES)) THEN 75 : BOOL2=.TRUE. 76 : DIML2=DIML2+1 77 : NOELON(DIML2)=Y 78 : NRELONG(Y)=LONG*2 79 : ENDIF 80 : 40 CONTINUE 81 : if (bool2) nrelong(X)=long*2-1 82 : 30 CONTINUE 83 : londim(long)=diml2 84 : IF (DIML2.GT.DIMLON) goto 20 85 : long=long-1 86 : C on s'arrete si il n'y a plus rien a faire 87 : * 88 : if (mode.ne.2.and.nbtot.ne.diml2) then 89 : * dans le cas ou la zone n'est pas connexe on va completer par 90 : * la partie non connexe 91 : do Y=1,NODES 92 : IF((NRELONG(Y).EQ.0).AND.(MDOMN.EQ.IPOS(Y+NODES))) THEN 93 : DIML2=DIML2+1 94 : NOELON(DIML2)=Y 95 : NRELONG(Y)=LONG*2 96 : goto 20 97 : ENDIF 98 : enddo 99 : endif 100 : ** write (6,*) ' noepr2 nbtot diml2 long ',nbtot,diml2,long 101 : londim(long)=diml2 102 : dimlon=diml2 103 : nbtot=dimlon 104 : * recherche de la distance de la frontiere 105 : decent=1.0 106 : nbcher=nbtot*decent/(decent+1) 107 : do 101 lfron=1,long 108 : nbpar=londim(lfron) 109 : if (nbpar.gt.nbcher) goto 102 110 : 101 continue 111 : 102 continue 112 : * identification de la frontiere 113 : fcout=1d50 114 : ld=max(2,((lfron-3)*15)/16) 115 : lf=max(min(((lfron+2)*17)/16,long-2),2) 116 : do 100 lfront2=ld,lf 117 : lfront1=lfront2 118 : nbpar=londim(lfront1) 119 : n1bz2=nbtot-nbpar 120 : if (n1bz2.eq.0) then 121 : lfront1=lfront2-1 122 : nbpar=londim(lfront1) 123 : n1bz2=nbtot-nbpar 124 : endif 125 : nbfr=0 126 : if (lfront1.le.1) then 127 : id=1 128 : else 129 : id=londim(lfront1-1)+1 130 : endif 131 : do 120 i=id,londim(lfront1) 132 : x=noelon(i) 133 : if (mod(nrelong(x),2).eq.1) nbfr=nbfr+1 134 : 120 continue 135 : * verification zone 2 connexe 136 : * if (londim(lfront1)+1.lt.lf) then 137 : * iconn=0 138 : * idep=noelon(londim(lfront1)+1) 139 : * x=idep 140 : * nrel=nrelong(x) 141 : * nrelong(x)=-nrel 142 : *127 continue 143 : * irb=0 144 : * do 125 i=londim(lfront1)+1,londim(min(lfront1+1,lf)) 145 : * x=noelon(i) 146 : * if (nrelong(x).lt.0) then 147 : * do 126 j=iadj(x),iadj(x+1)-1 148 : * y=jadjc(j) 149 : * if (nrelong(y)/2.eq.nrel/2) then 150 : * nrelong(y)=-nrelong(y) 151 : * irb=1 152 : * endif 153 : *126 continue 154 : * endif 155 : *125 continue 156 : * if (irb.eq.1) goto 127 157 : * do 128 i=londim(lfront1)+1,londim(min(lfront1+1,lf)) 158 : * x=noelon(i) 159 : * if (nrelong(x).lt.0) then 160 : * nrelong(x)=abs(nrelong(x)) 161 : * else 162 : * iconn=iconn+1 163 : * endif 164 : *128 continue 165 : * endif 166 : n1bz1=nbtot-n1bz2-nbfr 167 : * if (n1bz1.eq.0) goto 100 168 : ideseq=n1bz1-n1bz2*decent 169 : * if (iconn.ne.0) then 170 : * n1bz2=nbtot-n1bz1-nbfr-iconn 171 : * ideseq=max(n1bz1,n1bz2,iconn) 172 : * endif 173 : xbtot=nbtot 174 : xbfr=nbfr 175 : xdeseq=abs(ideseq) 176 : * x1bz1=n1bz1 177 : * x1bz2=n1bz2 178 : ** fcouu=(xbfr )**4 + (xdeseq )**3 179 : ** > -lfront1 180 : fcouu= 2*xbtot*xbfr+xbfr*xbfr*xbfr/3.0 +xdeseq**2 181 : > -lfront1 182 : if (nbfr.eq.0) then 183 : ** write (6,*) ' frontiere vide ',n1bz1,n1bz2,nbtot,mdomn 184 : fcouu=1 185 : endif 186 : if (fcouu.le.fcout) then 187 : nbz1=n1bz1 188 : nbz2=n1bz2 189 : lfront=lfront1 190 : fcout=fcouu 191 : endif 192 : 100 continue 193 : * write (6,*) ' noepr2 ',nbz1,nbz2,nbfr,lfront, 194 : * > long,nbtot,MDOMN 195 : isens=2 196 : if (nbz1.lt.nbz2) isens=1 197 : * mise a zero eventuel de nrelong 198 : if (mode.eq.1) then 199 : do i=1,londim(long) 200 : x=noelon(i) 201 : if (x.ne.0) nrelong(x)=0 202 : enddo 203 : endif 204 : if (mode.ne.1) then 205 : do i=1,londim(long) 206 : x=noelon(i) 207 : if (x.ne.0) nrelong(x)=nrelong(x)/2 208 : enddo 209 : endif 210 : lfron = long 211 : return 212 : end 213 : 214 : 215 : 216 : 217 : 218 : 219 : 220 : 221 : 222 : 223 : 224 : 225 : 226 :
© Cast3M 2003 - All rights reserved.
Disclaimer