C CCON SOURCE PV 07/11/23 21:15:34 5978 C separation en composantes connexes C C inspiré de numop2 SUBROUTINE CCON IMPLICIT INTEGER(I-N) -INC SMELEME -INC SMCOORD -INC CCOPTIO -INC SMTABLE SEGMENT JMEM(NODES+1) C JMEM contient le nombre d'element auquel appartient un noeud C puis ensuite la position du premier élément dans imemoir et lmemoir SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) C ICPR au debut contient l'ancienne numerotation , C a la fin la nouvelle. SEGMENT IMEMOIR(NBV),LMEMOIR(NBV) C contient les elements appartenant a chaque noeud,sous forme de liste. SEGMENT LISIND(NBS) C liste des indicateurs par sous-objets SEGMENT INDIC(NBEL) C indicateur du numéro de composante connexe SEGMENT LISCO1(NBV),LISCO2(NBV) C liste des elements voisins INTEGER ELEM C nom d'un element real*8 xx,cc character*1 charin logical login character*4 lmot(2) data lmot/'STR2','STR1'/ C********************************** C debut du program C********************************** C initialisation C******************************* call lirmot(lmot,2,imot,0) call lirobj('MAILLAGE',meleme,1,iretou) if (ierr.ne.0) return segact mcoord segini icpr segdes mcoord SEGACT MELEME C icpr: numero des noeuds. C meleme: objet de maillage (cf assem2.eso) IPT1=MELEME IKOU=0 NBV=0 DO 100 IO=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).GT.0) THEN IPT1=LISOUS(IO) SEGACT IPT1 ENDIF C on cree la numerotation des noeuds. C 'nb noeuds/element'=IPT1.NUM(/1) C 'nb element'=IPT1.NUM(/2) DO 150 J=1,IPT1.NUM(/2) DO 150 I=1,IPT1.NUM(/1) IJ=IPT1.NUM(I,J) C IJ est le Ième noeud du Jème élément. IF (ICPR(IJ).EQ.0) THEN C s'il est déjà numéroté, on ne fait rien. IKOU=IKOU+1 ICPR(IJ)=IKOU ENDIF 150 CONTINUE 100 CONTINUE NODES=IKOU C***** initalisationi et remplissage de JMEM ********* SEGINI JMEM ipt1=meleme DO 200 IO=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).GT.0) THEN IPT1=LISOUS(IO) ENDIF DO 250 J=1,IPT1.NUM(/2) DO 250 I=1,IPT1.NUM(/1) IJ=icpr(IPT1.NUM(I,J)) jmem(ij)=jmem(ij)+1 250 CONTINUE 200 CONTINUE do 290 i=1+1,nodes+1 jmem(i)=jmem(i)+jmem(i-1) 290 continue nbv=jmem(nodes) * write (6,*) ' nbv ',nbv C initialisation et remplissage de imemoir et lmemoir segini imemoir,lmemoir ipt1=meleme DO 300 IO=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).GT.0) THEN IPT1=LISOUS(IO) ENDIF DO 350 J=1,IPT1.NUM(/2) DO 350 I=1,IPT1.NUM(/1) IJ=icpr(IPT1.NUM(I,J)) * write (6,*) ' jmem(ij) ',jmem(ij) imemoir(jmem(ij))=j lmemoir(jmem(ij))=io jmem(ij)=jmem(ij)-1 350 CONTINUE 300 CONTINUE C************************************************************************** C travail segini lisco1,lisco2 NBS=max(1,LISOUS(/1)) SEGINI LISIND DO 500 IO=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IO) ELSE IPT1=MELEME ENDIF NBEL=IPT1.NUM(/2) * write (6,*) ' io nbel ',io,nbel SEGINI INDIC LISIND(IO)=INDIC 500 CONTINUE NBCOMP=0 ioc=1 ielc=0 1000 CONTINUE NBCOMP=NBCOMP+1 * write (6,*) ' nbcomp,ioc,ielc ',nbcomp,ioc,ielc ielc=ielc+1 do 1010 io=ioc,max(1,lisous(/1)) IF (LISOUS(/1).NE.0) THEN IPT1=LISOUS(IO) ELSE IPT1=MELEME ENDIF indic=lisind(io) do 1020 iel=ielc,ipt1.num(/2) if (indic(iel).eq.0) goto 1030 1020 continue ielc=1 1010 continue C tout est trié goto 1500 1030 continue ioc=io ielc=iel C on a trouvé un élément de départ on cherche les elements voisins indic(iel)=nbcomp ilrmp=1 lisco1(ilrmp)=io lisco2(ilrmp)=iel ilext=1 1120 continue if (ilext.gt.ilrmp) goto 1130 ion=lisco1(ilext) iel=lisco2(ilext) if (lisous(/1).ne.0) then ipt1=lisous(ion) else ipt1=meleme endif do 1100 in=1,ipt1.num(/1) ip=icpr(ipt1.num(in,iel)) do 1110 kk=jmem(ip)+1,jmem(ip+1) ion=lmemoir(kk) jn=imemoir(kk) indic=lisind(ion) if (indic(jn).ne.0) goto 1110 * tests supplémentaires si option stricte if (imot.ne.0) then if (lisous(/1).ne.0) then ipt2=lisous(ion) else ipt2=meleme endif endif * en option vérification qu'au moins 2 pts commun avec l'élément if (imot.eq.1) then do 1150 i1=1,ipt1.num(/1) ip1=icpr(ipt1.num(i1,iel)) if (ip1.eq.ip) goto 1150 do 1160 i2=1,ipt2.num(/1) ip2=icpr(ipt2.num(i2,jn)) if (ip1.eq.ip2) goto 1170 1160 continue 1150 continue goto 1110 1170 continue endif * eventuellement vérif qu'il n'y a que 2 éléments qui contiennent ip ip1 if (imot.eq.1) then nl=0 do 1180 k1=jmem(ip)+1,jmem(ip+1) if (k1.eq.kk) goto 1180 i1=lmemoir(k1) j1=imemoir(k1) do 1190 k2=jmem(ip1)+1,jmem(ip1+1) i2=lmemoir(k2) j2=imemoir(k2) if (i1.eq.i2.and.j1.eq.j2) nl=nl+1 1190 continue 1180 continue if (nl.ne.1) goto 1110 endif * eventuellement vérif qu'il n'y a que 2 éléments qui contiennent ip (cas des lignes) if (imot.eq.2) then if (jmem(ip+1)-jmem(ip).ne.2) goto 1110 endif indic(jn)=nbcomp ilrmp=ilrmp+1 lisco1(ilrmp)=ion lisco2(ilrmp)=jn 1110 continue 1100 continue ilext=ilext+1 goto 1120 1130 continue C on a fini, on enchaine sur la composante suivante goto 1000 1500 continue C il faut maintenant ranger les composantes connexes dans une table. nbcomp=nbcomp-1 * write (6,*) ' nbcomp a la fin ',nbcomp m=nbcomp segini mtable do 2000 icomp=1,nbcomp iss=0 C creation du chapeau nbnn=0 nbelem=0 nbsous=0 nbref=0 segini ipt7 iso=0 do 2010 is=1,max(1,lisous(/1)) if (lisous(/1).ne.0) then ipt1=lisous(is) else ipt1=meleme endif indic=lisind(is) ielem=0 do 2001 i=1,indic(/1) if (indic(i).eq.icomp) ielem=ielem+1 2001 continue if (ielem.ne.0) then iss=iss+1 nbnn=ipt1.num(/1) nbelem=ielem nbsous=0 nbref=0 segini ipt2 ipt2.itypel=ipt1.itypel ielem=0 do 2005 i=1,indic(/1) if (indic(i).ne.icomp) goto 2005 ielem=ielem+1 do 2006 j=1,ipt1.num(/1) ipt2.num(j,ielem)=ipt1.num(j,i) 2006 continue ipt2.icolor(ielem)=ipt1.icolor(i) 2005 continue nbnn=0 nbelem=0 nbsous=ipt7.lisous(/1)+1 nbref=0 segadj ipt7 ipt7.lisous(nbsous)=ipt2 segdes ipt2 endif 2010 continue if (ipt7.lisous(/1).eq.1) then ipt=ipt7.lisous(1) segsup ipt7 ipt7=ipt endif segdes ipt7 call ecctab(mtable,'ENTIER ',icomp,cc,charin,login,i, > 'MAILLAGE',i,xx,charin,login,ipt7) 2000 continue C c'est fini call ecrobj('TABLE ',mtable) segsup icpr,lmemoir,imemoir,lisco1,lisco2 do i=1,lisind(/1) indic=lisind(i) segsup indic enddo segsup lisind do i=1,lisous(/1) ipt1=lisous(i) segdes ipt1 enddo segdes meleme end