1 : C VMDISC SOURCE CHAT 07/10/29 21:30:16 5940 2 : SUBROUTINE VMDISC(melle) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C======================================================================= 7 : C Le but de cette subroutine est de savoir s'il n'y a pas 8 : C d'éléments connectés à des éléments d'une autre forme. 9 : C Ex: un CUB8 connecté à deux PRI6. 10 : C On utilise l'enveloppe car elle détecte ce genre de connexions. 11 : C On lit les sous objets et on compare leurs éléments. 12 : C Si un élément a tous ses points qui appartiennent aussi à un 13 : C autre élément on est dans le cas de figure à détecter. 14 : C 15 : C======================================================================= 16 : C 17 : C NB: On considère qu'il n'y a plus de points doubles inopportuns. 18 : C 19 : C======================================================================= 20 : C 21 : C Modifications : 22 : C 23 : C P. Maugis (04/08/2005) : 24 : C on lieu de faire une erreur sur une sous-zone non pertinente, 25 : C on passe à la sous-zone suivante 26 : C 27 : C======================================================================= 28 : C 29 : -INC CCOPTIO 30 : -INC CCGEOME 31 : -INC SMELEME 32 : -INC SMCOORD 33 : C 34 : C 35 : C======================================================================= 36 : C STOCK EST UN SEGMENT QUI CONTIENT UN VECTEUR STOCKANT LES 37 : C NUMEROS DES POINTS D'UN ELEMENT 38 : C======================================================================= 39 : SEGMENT STOCK 40 : INTEGER ivnum(jTAIL) 41 : ENDSEGMENT 42 : POINTEUR VINT.STOCK 43 : C 44 : C======================================================================= 45 : C UTILISATION D'ENVELOPPE (ON OBTIENT DES SURFACES) 46 : C======================================================================= 47 : 48 : C Uniquement en 3D 49 : IF(IDIM.NE.3) RETURN 50 : 51 : C On récupère l'enveloppe (plante si doublons) 51 : CALL ECROBJ('MAILLAGE',MELLE) 51 : CALL ENVELO 51 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 52 : IF (IERR.NE.0) RETURN 53 : 54 : SEGACT MELEME 55 : IPT1=MELEME 56 : C 57 : C Si l'on obtient un objet géométrique simple : pas de problème 58 : IF (LISOUS(/1).EQ.0) GOTO 14 59 : 60 : 61 : C======================================================================= 62 : C BOUCLE SUR LES SOUS OBJETS 63 : C======================================================================= 64 : 65 : DO 1 I=1,LISOUS(/1)-1 66 : IPT1=LISOUS(I) 67 : SEGACT IPT1 68 : 69 : * Vérifications d'usage 70 : K=IPT1.ITYPEL 71 : C on ne traite que les éléments surfaciques 72 : IF (K.NE.KSURF(K)) GOTO 1 73 : 74 : IDEP=NSPOS(K) 75 : IF (NBSOM(K).GT.0) THEN 76 : IFEP=IDEP+NBSOM(K)-1 77 : ELSE 78 : C Cas du polygone 79 : IFEP=IDEP+IPT1.NUM(/1)-1 80 : ENDIF 81 : 82 : * Il faut au moins deux points par face 83 : IF (IDEP.GT.IFEP) THEN 84 : write(IOIMP,*) 'Une face doit avoir au moins 3 points' 84 : CALL ERREUR (16) 85 : RETURN 86 : ENDIF 87 : 88 : jtail=IFEP-IDEP+1 89 : SEGINI STOCK 90 : 91 : C======================================================================= 92 : C BOUCLE SUR LES ELEMENTS DU SOUS OBJET N° I 93 : C======================================================================= 94 : vint=0 95 : DO 2 NEL=1,IPT1.NUM(/2) 96 : II=0 97 : C Enregistrement des n° des sommets de l'élément 98 : DO 3 NSP=IDEP,IFEP 99 : NSO=IBSOM(NSP) 100 : II=II+1 101 : ivnum(II)=IPT1.NUM(NSO,NEL) 102 : 3 CONTINUE 103 : MARQUE=0 104 : 105 : C======================================================================= 106 : C 2e BOUCLE SUR LES SOUS OBJETS (IS>I) 107 : C======================================================================= 108 : 109 : DO 4 IS=I+1,LISOUS(/1) 110 : 111 : IPT2=LISOUS(IS) 112 : SEGACT IPT2 113 : KS=IPT2.ITYPEL 114 : IDEPS=NSPOS(KS) 115 : IF (NBSOM(KS).GT.0) THEN 116 : IFEPS=IDEPS+NBSOM(KS)-1 117 : ELSE 118 : C Cas du polygone 119 : IFEPS=IDEPS+IPT1.NUM(/1)-1 120 : ENDIF 121 : IF (IDEPS.GT.IFEPS) THEN 122 : write(IOIMP,*) 'Une face doit avoir au moins 3 points' 122 : CALL ERREUR (16) 123 : RETURN 124 : ENDIF 125 : 126 : C======================================================================= 127 : C BOUCLE SUR LES ELEMENTS DU SOUS OBJET N° IS 128 : C======================================================================= 129 : 130 : DO 5 NELS=1,IPT2.NUM(/2) 131 : C Relecture de ivnum s'il avait été modifié 132 : IF (MARQUE.EQ.1) THEN 133 : jtail=mtailm 134 : SEGADJ STOCK 135 : DO 6 L=1,jtail 136 : ivnum(L)=VINT.ivnum(L) 137 : 6 CONTINUE 138 : MARQUE=0 139 : ENDIF 140 : 141 : C======================================================================= 142 : C On parcourt les sommets de nels, on parcourt 143 : C les coordonnées de vecnum en testant s'ils 144 : C ont les memes n°. 145 : C======================================================================= 146 : 147 : NSPS=IDEPS-1 148 : 7 CONTINUE 149 : 150 : NSPS=NSPS+1 151 : NSOS=IBSOM(NSPS) 152 : IF (NSPS.GT.IFEPS) GOTO 10 153 : jcp=0 154 : 8 CONTINUE 155 : 156 : jcp=jcp+1 157 : IF (jcp.GT.jtail) GOTO 5 158 : IF (IPT2.NUM(NSOS,NELS).EQ.ivnum(jcp)) THEN 159 : C On enregistre ivnum avant de le modifier 160 : IF (MARQUE.EQ.0) THEN 161 : mtailm=jtail 162 : SEGINI VINT 163 : DO 9 L=1,mtailm 164 : VINT.ivnum(L)=ivnum(L) 165 : 9 CONTINUE 166 : MARQUE=1 167 : ENDIF 168 : C On supprime la coordonée n° jcp de ivnum 169 : INT=ivnum(jtail) 170 : ivnum(jtail)=ivnum(jcp) 171 : ivnum(jcp)=INT 172 : jtail=jtail-1 173 : IF (jtail.EQ.0) GOTO 11 174 : SEGADJ STOCK 175 : GOTO 7 176 : ELSE 177 : GOTO 8 178 : ENDIF 179 : 180 : 10 CONTINUE 181 : INTERR(1)=NELS 182 : MOTERR(1:4)=NOMS(KS) 183 : INTERR(2)=NEL 184 : MOTERR(5:8)=NOMS(K) 184 : CALL ERREUR(-334) 185 : GOTO 12 186 : 187 : 11 CONTINUE 188 : INTERR(1)=NEL 189 : MOTERR(1:4)=NOMS(K) 190 : INTERR(2)=NELS 191 : MOTERR(5:8)=NOMS(KS) 191 : CALL ERREUR(-334) 192 : 193 : 12 CONTINUE 194 : 5 CONTINUE 195 : 4 CONTINUE 196 : IF (MARQUE.EQ.1) THEN 197 : jtail=mtailm 198 : SEGADJ STOCK 199 : DO 13 L=1,jtail 200 : ivnum(L)=VINT.ivnum(L) 201 : 13 CONTINUE 202 : MARQUE=0 203 : ENDIF 204 : 205 : 2 CONTINUE 206 : SEGDES STOCK 207 : IF(VINT.NE.0)SEGSUP VINT 208 : 1 CONTINUE 209 : 210 : 14 CONTINUE 211 : SEGDES MELEME 212 : 213 : RETURN 214 : END 215 : 216 : 217 : 218 : 219 : 220 : 221 : 222 : 223 : 224 : 225 : 226 : 227 : 228 : 229 : 230 : 231 :
© Cast3M 2003 - All rights reserved.
Disclaimer