C INTERC SOURCE PV 20/03/30 21:20:02 10567 C C CE SOUS PROGRAMME REALISE l'intersection ensembliste de deux maillages C simples (1 seul type d'element) C Les maillages IPT1 et IPT2 sont supposes ACTIF en E/S (non modifies) C Si pas d'intersection, IPT3 = 0 sinon pointeur MELEME (ACTIF en S) C SUBROUTINE INTERC(IPT1,IPT2, IPT3) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD segment ipos(nbpt) segment ind(mm) IPT3 = 0 C* SEGACT IPT1,IPT2 <- Segments actifs en Entree NBNN1=IPT1.NUM(/1) NBNN2=IPT2.NUM(/1) C Un des maillages n'est pas simple : IF (NBNN1.EQ.0 .OR. NBNN2.EQ.0) GOTO 900 NBELE1=IPT1.NUM(/2) NBELE2=IPT2.NUM(/2) ITYP1 =IPT1.ITYPEL ITYP2 =IPT2.ITYPEL C Les maillages ne sont pas du meme type : IF ((ITYP1.NE.ITYP2) .OR. (NBNN1.NE.NBNN2)) GOTO 900 NBNN = NBNN1 NBELEM = MAX(NBELE1,NBELE2) NBREF = 0 NBSOUS = 0 SEGINI,MELEME ITYPEL = ITYP1 C Creation de ipos SEGACT,mcoord np = nbpts nbpt = np + 1 SEGINI,ipos C Remplissage de ipos DO 10 i = 1, NBELE1 DO 11 j = 1, NBNN1 ia=ipt1.num(j,i) ipos(ia)=ipos(ia)+1 11 CONTINUE 10 CONTINUE i_z = ipos(1) DO 13 i = 2, np i_z = i_z + ipos(i) ipos(i) = i_z 13 CONTINUE mm = ipos(np) ipos(nbpt) = mm C Creation de ind SEGINI,ind C Remplissage de ind DO 20 i = 1, NBELE1 DO 21 j = 1, NBNN1 ia = ipt1.num(j,i) ide=ipos(ia) ind(ide)=i ipos(ia)=ide-1 21 CONTINUE 20 CONTINUE * Remplissage de l'intersection I=0 DO 1 i1 = 1, NBELE2 ia=ipt2.num(1,i1) ideb=ipos(ia)+1 ifin=ipos(ia+1) IF (ifin.lt.ideb) go to 1 DO 2 ie=ideb,ifin iel=ind(ie) DO 134 in1=1,NBNN1 DO 136 in2=1,NBNN2 IF(ipt1.num(in1,iel).EQ.ipt2.num(in2,i1)) GOTO 134 136 CONTINUE GOTO 2 134 CONTINUE C OK pour cet element I=I+1 ICOLOR(I)=IPT1.ICOLOR(Iel) DO 135 J=1,NBNN NUM(J,I)=IPT1.NUM(J,iel) 135 CONTINUE GOTO 1 2 CONTINUE 1 CONTINUE SEGSUP,ipos,ind NBELEM = I IF (NBELEM.EQ.0) THEN SEGSUP,MELEME IPT3 = 0 ELSE SEGADJ,MELEME C* SEGDES,MELEME <- Segment cree actif en sortie IPT3 = MELEME ENDIF 900 CONTINUE C* SEGDES,IPT1,IPT2 <- Segments actifs en Sortie (non modifies) RETURN END