1 : C OUEXCL SOURCE MAUGIS 07/10/10 21:15:07 5889 2 : SUBROUTINE OUEXCL(IPT1,IPT2,MELEME) 3 : *============================================================= 4 : * 5 : * CE SOUS PROGRAMME REALISE L'OPERATION "OU EXCLUSIF" SUR DEUX LIGNES 6 : * IL INTERVIENT DANS LA FUSION DES CONTOURS DE DEUX OBJETS SURFACIQUE 7 : * 8 : *============================================================= 9 : * 10 : * Création : ??? 11 : * Modifications : PM 05/10/2007 12 : * gère les éléments dégénérés (à noeuds doubles) 13 : * 14 : *============================================================= 15 : * 16 : * REMARQUES: 17 : * 18 : *============================================================= 19 : IMPLICIT INTEGER(I-N) 20 : -INC CCOPTIO 21 : -INC SMELEME 22 : -INC SMCOORD 23 : SEGMENT INV(NBT) 24 : SEGMENT NINV(NBNO) 25 : SEGMENT NPOS(NBNO) 26 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 27 : SEGMENT IVU(NBVU) 28 : 29 : SEGACT IPT1,IPT2 30 : 31 : * Type d'élément incorrect ? 31 : IF (IPT1.ITYPEL .NE.IPT2.ITYPEL ) CALL ERREUR(16) 31 : IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) CALL ERREUR(16) 32 : IF (IERR.NE.0) RETURN 33 : 34 : NBREF = 0 35 : NBNN = IPT1.NUM(/1) 36 : NBELE1 = IPT1.NUM(/2) 37 : NBELE2 = IPT2.NUM(/2) 38 : 39 : * DETERMINATION DU NOMBRE DE NOEUDS 40 : SEGACT MCOORD 41 : SEGINI ICPR 42 : NBNO=0 43 : DO I=1,NBELE1 44 : DO 15 J=1,NBNN 45 : IPT=IPT1.NUM(J,I) 46 : IF (ICPR(IPT).NE.0) GOTO 15 47 : NBNO=NBNO+1 48 : ICPR(IPT)=NBNO 49 : 15 CONTINUE 50 : ENDDO 51 : 52 : * NB MAX ELEMENTS TOUCHANT UN NOEUD 53 : SEGINI NINV,NPOS 54 : DO I=1,NBELE1 55 : DO J=1,NBNN 56 : NINV(ICPR(IPT1.NUM(J,I)))=NINV(ICPR(IPT1.NUM(J,I)))+1 57 : ENDDO 58 : ENDDO 59 : NBC=0 60 : NBT=0 61 : DO I=1,NBNO 62 : NBC=MAX(NBC,NINV(I)) 63 : NPOS(I)=NBT 64 : NBT=NBT+NINV(I) 65 : NINV(I)=0 66 : ENDDO 67 : SEGINI INV 68 : DO I=1,NBELE1 69 : DO J=1,NBNN 70 : IPP=ICPR(IPT1.NUM(J,I)) 71 : NINV(IPP)=NINV(IPP)+1 72 : INV(NPOS(IPP)+NINV(IPP))=I 73 : ENDDO 74 : ENDDO 75 : 76 : * Création table d'indicateur de noeud déjà trouvé 77 : NBVU=NBNN 78 : SEGINI, IVU 79 : 80 : * CREATION DE LA DIFFERENCE SYMETRIQUE 81 : NBSOUS=0 82 : NBELEM=NBELE1+NBELE2 83 : SEGINI MELEME 84 : DO I=1,NBELE1 85 : ICOLOR(I)=IPT1.ICOLOR(I) 86 : DO J=1,NBNN 87 : NUM(J,I)=IPT1.NUM(J,I) 88 : ENDDO 89 : ENDDO 90 : 91 : DO I=1,NBELE2 92 : ICOLOR(I+NBELE1)=IPT2.ICOLOR(I) 93 : DO J=1,NBNN 94 : NUM(J,I+NBELE1)=IPT2.NUM(J,I) 95 : ENDDO 96 : ENDDO 97 : 98 : DO 2 I=1,NBELE2 99 : DO J=1,NBNN 100 : IPP=ICPR(NUM(J,I+NBELE1)) 101 : IF (IPP.EQ.0) GOTO 2 102 : DO 23 K=1,NINV(IPP) 103 : IEL=INV(NPOS(IPP)+K) 104 : * Comparaison des numéros de noeud de l'élément 105 : * ICOIN=nb de noeuds qui conviennent 106 : ICOIN=0 107 : DO M=1,NBNN 108 : IVU(M)=0 109 : ENDDO 110 : DO 24 L=1,NBNN 111 : DO M=1,NBNN 112 : *PM On ne teste que les noeuds non encore identifiés. 113 : IF (NUM(M,IEL).EQ.NUM(L,I+NBELE1) .AND. 114 : & IVU(M).EQ.0) THEN 115 : ICOIN = ICOIN + 1 116 : IVU(M) = 1 117 : GOTO 24 118 : ENDIF 119 : ENDDO 120 : 24 CONTINUE 121 : 122 : IF (ICOIN.NE.NBNN) GOTO 23 123 : * Les deux élements coincident 124 : NUM(1,I+NBELE1)=-NUM(1,I+NBELE1) 125 : NUM(1,IEL)=-NUM(1,IEL) 126 : NBELEM=NBELEM-2 127 : * WRITE (6,*) ' COINCIDE ',I,IEL,NBELEM,NBELE1,NBELE2,NBNN 128 : GOTO 2 129 : 23 CONTINUE 130 : ENDDO 131 : 2 CONTINUE 132 : 133 : * RETASSER LE MELEME RÉSULTAT 134 : IPT3=MELEME 135 : MELEME=0 136 : IF(NBELEM.EQ.0) SEGSUP IPT3 137 : IF(NBELEM.EQ.0) RETURN 138 : 139 : SEGINI MELEME 140 : ITYPEL=IPT1.ITYPEL 141 : SEGDES IPT1,IPT2 142 : 143 : J=1 144 : DO I=1,NBELEM 145 : 51 IF (IPT3.NUM(1,J).GT.0) GOTO 52 146 : J=J+1 147 : GOTO 51 148 : 52 DO K=1,NBNN 149 : NUM(K,I)=IPT3.NUM(K,J) 150 : ENDDO 151 : ICOLOR(I)=IPT3.ICOLOR(J) 152 : J=J+1 153 : ENDDO 154 : 155 : SEGSUP IPT3,INV,NINV,NPOS,IVU 156 : RETURN 157 : END 158 : 159 : 160 : 161 : 162 :
© Cast3M 2003 - All rights reserved.
Disclaimer