disjo
C DISJO SOURCE CHAT 10/12/21 21:15:07 6831 SUBROUTINE disjo(IPT1,IPT2,MELEME,ipt4,ipt5,icpr) * * a partir de deux maillages elementaires de meme itypel (ipt1,ipt2) * realise trois maillages : meleme intersection de ipt1 et ipt2 * ipt4 partie de ipt1 pas dans ipt2 * ipt5 partiere de ipt2 pas dans ipt1 * les pointeurs valent zero si rien dedans IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD SEGMENT IVU(NBVU) segment icpr(ino) SEGACT IPT1,IPT2 * Type d'élément incorrect ? IF (IERR.NE.0) RETURN NBREF = 0 NBNN = IPT1.NUM(/1) NBELE1 = IPT1.NUM(/2) NBELE2 = IPT2.NUM(/2) * DETERMINATION DU NOMBRE DE NOEUDS SEGACT MCOORD * SEGINI ICPR do io=1,icpr(/1) icpr(io)=0 enddo DO I=1,NBELE1 DO 15 J=1,NBNN IPT=IPT1.NUM(J,I) IF (ICPR(IPT).NE.0) GOTO 15 15 CONTINUE ENDDO * NB MAX ELEMENTS TOUCHANT UN NOEUD SEGINI NINV,NPOS DO I=1,NBELE1 DO J=1,NBNN NINV(ICPR(IPT1.NUM(J,I)))=NINV(ICPR(IPT1.NUM(J,I)))+1 ENDDO ENDDO NBC=0 NBT=0 NBC=MAX(NBC,NINV(I)) NPOS(I)=NBT NBT=NBT+NINV(I) NINV(I)=0 ENDDO SEGINI INV DO I=1,NBELE1 DO J=1,NBNN IPP=ICPR(IPT1.NUM(J,I)) NINV(IPP)=NINV(IPP)+1 ENDDO ENDDO * Création table d'indicateur de noeud déjà trouvé NBVU=NBNN SEGINI, IVU * CREATION DE LA DIFFERENCE SYMETRIQUE NBSOUS=0 nbref=0 NBELEM=NBELE1+NBELE2 SEGINI MELEME DO I=1,NBELE1 ICOLOR(I)=IPT1.ICOLOR(I) DO J=1,NBNN NUM(J,I)=IPT1.NUM(J,I) ENDDO ENDDO DO I=1,NBELE2 ICOLOR(I+NBELE1)=IPT2.ICOLOR(I) DO J=1,NBNN NUM(J,I+NBELE1)=IPT2.NUM(J,I) ENDDO ENDDO nbelem=0 DO 2 I=1,NBELE2 DO J=1,NBNN * write(6,* ) 'NUM(J,I+NBELE1)',NUM(J,I+NBELE1) IPP=ICPR(NUM(J,I+NBELE1)) IF (IPP.EQ.0) GOTO 2 DO 23 K=1,NINV(IPP) * Comparaison des numéros de noeud de l'élément * ICOIN=nb de noeuds qui conviennent ICOIN=0 DO M=1,NBNN IVU(M)=0 ENDDO DO 24 L=1,NBNN DO M=1,NBNN *PM On ne teste que les noeuds non encore identifiés. IF (NUM(M,IEL).EQ.NUM(L,I+NBELE1) .AND. & IVU(M).EQ.0) THEN ICOIN = ICOIN + 1 IVU(M) = 1 GOTO 24 ENDIF ENDDO 24 CONTINUE IF (ICOIN.NE.NBNN) GOTO 23 * Les deux élements coincident NUM(1,I+NBELE1)=-NUM(1,I+NBELE1) NUM(1,IEL)=0 NBELEM=NBELEM+1 * WRITE (6,*) ' COINCIDE ',I,IEL,NBELEM,NBELE1,NBELE2,NBNN GOTO 2 23 CONTINUE ENDDO 2 CONTINUE * RETASSER LE MELEME RÉSULTAT IPT3=MELEME * write(6,*) 'nbelem ',nbelem IF(NBELEM.EQ.0) then * les maillages sont disjoints pas d'intersection meleme=0 else nbmil=nbelem SEGINI MELEME nbnn=ipt1.num(/1) nbelem= nbele1 - nbmil if( nbelem.eq.0) then * le premier ipt1 etait inclus dans ipt2 ipt4=0 else segini ipt4 ipt4.itypel=IPT1.ITYPEL endif nbelem= nbele2 - nbmil if( nbelem.eq.0) then * le ipt2 etait inclus dans ipt1 ipt5=0 else segini ipt5 ipt5.itypel=IPT1.ITYPEL endif ITYPEL=IPT1.ITYPEL I=0 I4=0 I5=0 DO J=1,NBELE1+nbele2 IF(ipt3.num(1,j).eq.0) go to 36 IF (IPT3.NUM(1,J).lt.0) then I=I+1 DO K=1,NBNN NUM(K,I)=abs(IPT3.NUM(K,J)) ENDDO ICOLOR(I)=IPT3.ICOLOR(J) ELSEIF (J.le.nbele1) then I4=I4+1 DO K=1,NBNN ipt4.NUM(K,I4)=IPT3.NUM(K,J) ENDDO ipt4.ICOLOR(I4)=IPT3.ICOLOR(J) ELSE I5=I5+1 DO K=1,NBNN ipt5.NUM(K,I5)=IPT3.NUM(K,J) ENDDO ipt5.ICOLOR(I5)=IPT3.ICOLOR(J) ENDIF 36 continue ENDDO endif * write(6,*) ' sortir disjo ', ipt4,ipt5,meleme SEGSUP IPT3,INV,NINV,NPOS,IVU RETURN END
© Cast3M 2003 - Tous droits réservés.
Mentions légales