1 : C CCON SOURCE PV 07/11/23 21:15:34 5978 2 : C separation en composantes connexes 3 : C 4 : C inspiré de numop2 5 : 6 : SUBROUTINE CCON 7 : IMPLICIT INTEGER(I-N) 8 : -INC SMELEME 9 : -INC SMCOORD 10 : -INC CCOPTIO 11 : -INC SMTABLE 12 : 13 : SEGMENT JMEM(NODES+1) 14 : C JMEM contient le nombre d'element auquel appartient un noeud 15 : C puis ensuite la position du premier élément dans imemoir et lmemoir 16 : 17 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 18 : C ICPR au debut contient l'ancienne numerotation , 19 : C a la fin la nouvelle. 20 : 21 : SEGMENT IMEMOIR(NBV),LMEMOIR(NBV) 22 : C contient les elements appartenant a chaque noeud,sous forme de liste. 23 : 24 : SEGMENT LISIND(NBS) 25 : C liste des indicateurs par sous-objets 26 : 27 : SEGMENT INDIC(NBEL) 28 : C indicateur du numéro de composante connexe 29 : 30 : SEGMENT LISCO1(NBV),LISCO2(NBV) 31 : C liste des elements voisins 32 : 33 : INTEGER ELEM 34 : C nom d'un element 35 : 36 : real*8 xx,cc 37 : character*1 charin 38 : logical login 39 : character*4 lmot(2) 40 : data lmot/'STR2','STR1'/ 41 : 42 : C********************************** 43 : 44 : C debut du program 45 : 46 : C********************************** 47 : 48 : 49 : 50 : C initialisation 51 : C******************************* 51 : call lirmot(lmot,2,imot,0) 51 : call lirobj('MAILLAGE',meleme,1,iretou) 52 : if (ierr.ne.0) return 53 : segact mcoord 54 : segini icpr 55 : segdes mcoord 56 : SEGACT MELEME 57 : C icpr: numero des noeuds. 58 : C meleme: objet de maillage (cf assem2.eso) 59 : 60 : IPT1=MELEME 61 : IKOU=0 62 : NBV=0 63 : 64 : DO 100 IO=1,MAX(1,LISOUS(/1)) 65 : IF (LISOUS(/1).GT.0) THEN 66 : IPT1=LISOUS(IO) 67 : SEGACT IPT1 68 : ENDIF 69 : C on cree la numerotation des noeuds. 70 : C 'nb noeuds/element'=IPT1.NUM(/1) 71 : C 'nb element'=IPT1.NUM(/2) 72 : DO 150 J=1,IPT1.NUM(/2) 73 : DO 150 I=1,IPT1.NUM(/1) 74 : IJ=IPT1.NUM(I,J) 75 : C IJ est le Ième noeud du Jème élément. 76 : IF (ICPR(IJ).EQ.0) THEN 77 : C s'il est déjà numéroté, on ne fait rien. 78 : IKOU=IKOU+1 79 : ICPR(IJ)=IKOU 80 : ENDIF 81 : 150 CONTINUE 82 : 100 CONTINUE 83 : 84 : NODES=IKOU 85 : 86 : C***** initalisationi et remplissage de JMEM ********* 87 : 88 : SEGINI JMEM 89 : ipt1=meleme 90 : DO 200 IO=1,MAX(1,LISOUS(/1)) 91 : IF (LISOUS(/1).GT.0) THEN 92 : IPT1=LISOUS(IO) 93 : ENDIF 94 : DO 250 J=1,IPT1.NUM(/2) 95 : DO 250 I=1,IPT1.NUM(/1) 96 : IJ=icpr(IPT1.NUM(I,J)) 97 : jmem(ij)=jmem(ij)+1 98 : 250 CONTINUE 99 : 200 CONTINUE 100 : 101 : do 290 i=1+1,nodes+1 102 : jmem(i)=jmem(i)+jmem(i-1) 103 : 290 continue 104 : nbv=jmem(nodes) 105 : * write (6,*) ' nbv ',nbv 106 : 107 : C initialisation et remplissage de imemoir et lmemoir 108 : 109 : segini imemoir,lmemoir 110 : 111 : ipt1=meleme 112 : DO 300 IO=1,MAX(1,LISOUS(/1)) 113 : IF (LISOUS(/1).GT.0) THEN 114 : IPT1=LISOUS(IO) 115 : ENDIF 116 : DO 350 J=1,IPT1.NUM(/2) 117 : DO 350 I=1,IPT1.NUM(/1) 118 : IJ=icpr(IPT1.NUM(I,J)) 119 : * write (6,*) ' jmem(ij) ',jmem(ij) 120 : imemoir(jmem(ij))=j 121 : lmemoir(jmem(ij))=io 122 : jmem(ij)=jmem(ij)-1 123 : 350 CONTINUE 124 : 300 CONTINUE 125 : 126 : 127 : C************************************************************************** 128 : C travail 129 : 130 : segini lisco1,lisco2 131 : 132 : NBS=max(1,LISOUS(/1)) 133 : SEGINI LISIND 134 : 135 : DO 500 IO=1,MAX(1,LISOUS(/1)) 136 : IF (LISOUS(/1).NE.0) THEN 137 : IPT1=LISOUS(IO) 138 : ELSE 139 : IPT1=MELEME 140 : ENDIF 141 : NBEL=IPT1.NUM(/2) 142 : * write (6,*) ' io nbel ',io,nbel 143 : SEGINI INDIC 144 : LISIND(IO)=INDIC 145 : 500 CONTINUE 146 : 147 : NBCOMP=0 148 : ioc=1 149 : ielc=0 150 : 1000 CONTINUE 151 : NBCOMP=NBCOMP+1 152 : * write (6,*) ' nbcomp,ioc,ielc ',nbcomp,ioc,ielc 153 : ielc=ielc+1 154 : do 1010 io=ioc,max(1,lisous(/1)) 155 : IF (LISOUS(/1).NE.0) THEN 156 : IPT1=LISOUS(IO) 157 : ELSE 158 : IPT1=MELEME 159 : ENDIF 160 : indic=lisind(io) 161 : do 1020 iel=ielc,ipt1.num(/2) 162 : if (indic(iel).eq.0) goto 1030 163 : 1020 continue 164 : ielc=1 165 : 1010 continue 166 : C tout est trié 167 : goto 1500 168 : 1030 continue 169 : ioc=io 170 : ielc=iel 171 : C on a trouvé un élément de départ on cherche les elements voisins 172 : indic(iel)=nbcomp 173 : ilrmp=1 174 : lisco1(ilrmp)=io 175 : lisco2(ilrmp)=iel 176 : ilext=1 177 : 1120 continue 178 : if (ilext.gt.ilrmp) goto 1130 179 : ion=lisco1(ilext) 180 : iel=lisco2(ilext) 181 : if (lisous(/1).ne.0) then 182 : ipt1=lisous(ion) 183 : else 184 : ipt1=meleme 185 : endif 186 : do 1100 in=1,ipt1.num(/1) 187 : ip=icpr(ipt1.num(in,iel)) 188 : do 1110 kk=jmem(ip)+1,jmem(ip+1) 189 : ion=lmemoir(kk) 190 : jn=imemoir(kk) 191 : indic=lisind(ion) 192 : if (indic(jn).ne.0) goto 1110 193 : * tests supplémentaires si option stricte 194 : if (imot.ne.0) then 195 : if (lisous(/1).ne.0) then 196 : ipt2=lisous(ion) 197 : else 198 : ipt2=meleme 199 : endif 200 : endif 201 : * en option vérification qu'au moins 2 pts commun avec l'élément 202 : if (imot.eq.1) then 203 : do 1150 i1=1,ipt1.num(/1) 204 : ip1=icpr(ipt1.num(i1,iel)) 205 : if (ip1.eq.ip) goto 1150 206 : do 1160 i2=1,ipt2.num(/1) 207 : ip2=icpr(ipt2.num(i2,jn)) 208 : if (ip1.eq.ip2) goto 1170 209 : 1160 continue 210 : 1150 continue 211 : goto 1110 212 : 1170 continue 213 : endif 214 : * eventuellement vérif qu'il n'y a que 2 éléments qui contiennent ip ip1 215 : if (imot.eq.1) then 216 : nl=0 217 : do 1180 k1=jmem(ip)+1,jmem(ip+1) 218 : if (k1.eq.kk) goto 1180 219 : i1=lmemoir(k1) 220 : j1=imemoir(k1) 221 : do 1190 k2=jmem(ip1)+1,jmem(ip1+1) 222 : i2=lmemoir(k2) 223 : j2=imemoir(k2) 224 : if (i1.eq.i2.and.j1.eq.j2) nl=nl+1 225 : 1190 continue 226 : 1180 continue 227 : if (nl.ne.1) goto 1110 228 : endif 229 : * eventuellement vérif qu'il n'y a que 2 éléments qui contiennent ip (cas des lignes) 230 : if (imot.eq.2) then 231 : if (jmem(ip+1)-jmem(ip).ne.2) goto 1110 232 : endif 233 : 234 : indic(jn)=nbcomp 235 : ilrmp=ilrmp+1 236 : lisco1(ilrmp)=ion 237 : lisco2(ilrmp)=jn 238 : 1110 continue 239 : 1100 continue 240 : ilext=ilext+1 241 : goto 1120 242 : 1130 continue 243 : C on a fini, on enchaine sur la composante suivante 244 : goto 1000 245 : 1500 continue 246 : C il faut maintenant ranger les composantes connexes dans une table. 247 : nbcomp=nbcomp-1 248 : * write (6,*) ' nbcomp a la fin ',nbcomp 249 : m=nbcomp 250 : segini mtable 251 : do 2000 icomp=1,nbcomp 252 : iss=0 253 : C creation du chapeau 254 : nbnn=0 255 : nbelem=0 256 : nbsous=0 257 : nbref=0 258 : segini ipt7 259 : iso=0 260 : do 2010 is=1,max(1,lisous(/1)) 261 : if (lisous(/1).ne.0) then 262 : ipt1=lisous(is) 263 : else 264 : ipt1=meleme 265 : endif 266 : indic=lisind(is) 267 : ielem=0 268 : do 2001 i=1,indic(/1) 269 : if (indic(i).eq.icomp) ielem=ielem+1 270 : 2001 continue 271 : if (ielem.ne.0) then 272 : iss=iss+1 273 : nbnn=ipt1.num(/1) 274 : nbelem=ielem 275 : nbsous=0 276 : nbref=0 277 : segini ipt2 278 : ipt2.itypel=ipt1.itypel 279 : ielem=0 280 : do 2005 i=1,indic(/1) 281 : if (indic(i).ne.icomp) goto 2005 282 : ielem=ielem+1 283 : do 2006 j=1,ipt1.num(/1) 284 : ipt2.num(j,ielem)=ipt1.num(j,i) 285 : 2006 continue 286 : ipt2.icolor(ielem)=ipt1.icolor(i) 287 : 2005 continue 288 : nbnn=0 289 : nbelem=0 290 : nbsous=ipt7.lisous(/1)+1 291 : nbref=0 292 : segadj ipt7 293 : ipt7.lisous(nbsous)=ipt2 294 : segdes ipt2 295 : endif 296 : 2010 continue 297 : if (ipt7.lisous(/1).eq.1) then 298 : ipt=ipt7.lisous(1) 299 : segsup ipt7 300 : ipt7=ipt 301 : endif 302 : segdes ipt7 302 : call ecctab(mtable,'ENTIER ',icomp,cc,charin,login,i, 303 : > 'MAILLAGE',i,xx,charin,login,ipt7) 304 : 2000 continue 305 : 306 : C c'est fini 306 : call ecrobj('TABLE ',mtable) 307 : segsup icpr,lmemoir,imemoir,lisco1,lisco2 308 : do i=1,lisind(/1) 309 : indic=lisind(i) 310 : segsup indic 311 : enddo 312 : segsup lisind 313 : do i=1,lisous(/1) 314 : ipt1=lisous(i) 315 : segdes ipt1 316 : enddo 317 : segdes meleme 318 : end 319 : 320 : 321 :
© Cast3M 2003 - All rights reserved.
Disclaimer