1 : C CHANLG SOURCE PV 12/04/13 21:15:19 7351 2 : C CE SOUS PROGRAMME FABRIQUE L'ENSEMBLE DES ARETES D'UN MAILLAGE 3 : C IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES 4 : C 5 : SUBROUTINE CHANLG 6 : IMPLICIT INTEGER(I-N) 7 : -INC CCOPTIO 8 : -INC CCGEOME 9 : -INC SMELEME 10 : -INC SMCOORD 11 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 12 : SEGMENT IDCP(ITE) 13 : SEGMENT NTSEG(0) 14 : SEGMENT KON(NBCON,NMAX,3) 14 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 15 : 16 : IF (IERR.NE.0) RETURN 17 : IPT8=MELEME 18 : SEGACT MELEME 19 : 20 : SEGINI ICPR 21 : 22 : DO 1 I=1,ICPR(/1) 23 : ICPR(I)=0 24 : 1 CONTINUE 25 : 26 : ITE=0 27 : IPT1=MELEME 28 : 29 : DO 3 I=1,MAX(1,LISOUS(/1)) 30 : 31 : IF (LISOUS(/1).NE.0) THEN 32 : IPT1=LISOUS(I) 33 : SEGACT IPT1 34 : ENDIF 35 : 36 : K=IPT1.ITYPEL 37 : IDEP=NSPOS(K) 38 : if (idep.eq.0) goto 8 39 : IF (NBSOM(K).GT.0) THEN 40 : IFEP=IDEP+NBSOM(K)-1 41 : ELSE 42 : C Cas du polygone 43 : IFEP=IDEP+IPT1.NUM(/1)-1 44 : ENDIF 45 : 46 : IF (IFEP.LT.IDEP) GOTO 8 47 : 48 : DO 4 JJ=IDEP,IFEP 49 : J=IBSOM(JJ) 50 : DO 4 K=1,IPT1.NUM(/2) 51 : IPOIT=IPT1.NUM(J,K) 52 : IF (ICPR(IPOIT).NE.0) GOTO 7 53 : ITE=ITE+1 54 : ICPR(IPOIT)=ITE 55 : 7 CONTINUE 56 : 4 CONTINUE 57 : 8 CONTINUE 58 : IF (LISOUS(/1).NE.0) SEGDES IPT1 59 : 60 : 3 CONTINUE 61 : 62 : SEGDES MELEME 63 : 64 : IF (ITE.NE.0) GOTO 6 65 : SEGSUP ICPR 65 : CALL ERREUR(16) 66 : RETURN 67 : 6 CONTINUE 68 : 69 : C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU 70 : C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS 71 : NBCON=7 72 : NBCONR=NBCON-1 73 : NMAX=(10*ITE) 74 : SEGINI KON 75 : C MISE A ZERO DU TABLEAU KON 76 : DO 10 K=1,3 77 : DO 10 I=1,NMAX 78 : DO 10 J=1,NBCON 79 : 10 KON(J,I,K)=0 80 : 81 : C FABRICATION DU TABLEAU DES CONNECTIONS 82 : C 1 POINT FINAL 83 : C 2 POINT INTERMEDIAIRE EVENTUEL ET SENS 84 : ICHAIN=ITE 85 : SEGACT MELEME 86 : IPT1=MELEME 87 : IOO=0 88 : IA=0 89 : 90 : DO 30 IO=1,MAX(1,LISOUS(/1)) 91 : 92 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 93 : 94 : SEGACT IPT1 95 : K=IPT1.ITYPEL 96 : If( K.eq.22) then 97 : segdes ipt1 98 : goto 30 99 : endif 100 : NBNN=KDEGRE(K) 101 : 102 : IF (IA.EQ.0) IA=NBNN 103 : 104 : IF (NBNN.NE.IA) THEN 105 : PRINT *,'*MAILLAGE IMPOSSIBLE' 106 : PRINT *,'*EXISTENCE D''ELEMENTS DONNANT' 107 : PRINT *,'*DES SEG2 ET DES SEG3' 108 : SEGSUP KON,ICPR 109 : SEGDES MELEME 110 : RETURN 111 : ENDIF 112 : 113 : IPAS=NBNN-1 114 : KKK=LTEL(1,K) 115 : 116 : IF (KKK.EQ.0) THEN 117 : 118 : DO 122 I=1,IPT1.NUM(/2) 119 : 120 : NMIL=1 121 : N1=ICPR(IPT1.NUM(1,I)) 122 : JSUIV=1+IPAS 123 : N2=ICPR(IPT1.NUM(JSUIV,I)) 124 : IF (IPAS.EQ.2) NMIL=IPT1.NUM(1+1,I) 125 : NI=N1 126 : NJ=N2 127 : IF (N1*N2.EQ.0) GOTO 32 128 : KSCOL=IPT1.ICOLOR(I) 129 : * PRINT *,'*KSCOL',KSCOL 130 : IPO=0 131 : 132 : 123 CONTINUE 133 : 124 DO 125 IK=1,NBCONR 134 : IF (KON(IK,NI,1).EQ.0) GOTO 126 135 : IF (KON(IK,NI,1).EQ.NJ) GOTO 129 136 : 125 CONTINUE 137 : 138 : IF (KON(NBCON,NI,1).EQ.0) GOTO 128 139 : NI=KON(NBCON,NI,1) 140 : GOTO 124 141 : 142 : 126 KON(IK,NI,1)=NJ 143 : KON(IK,NI,2)=NMIL 144 : KON(IK,NI,3)=KSCOL 145 : GOTO 129 146 : 147 : 128 ICHAIN=ICHAIN+1 148 : IF (ICHAIN.GE.NMAX) GOTO 32 149 : KON(NBCON,NI,1)=ICHAIN 150 : IK=1 151 : NI=ICHAIN 152 : GOTO 126 153 : 154 : 129 IF (IPO.EQ.1) GOTO 122 155 : NMIL=-NMIL 156 : NI=N2 157 : NJ=N1 158 : IPO=1 159 : GOTO 123 160 : 161 : 122 CONTINUE 162 : 163 : ELSE 164 : IOO=1 165 : KK=LTEL(2,K)-1 166 : 167 : DO 300 III=1,KKK 168 : C ****BOUCLE PERMETTANT D'ALLER RECHERCHER TOUTES LES FACES 169 : 170 : KK=KK+1 171 : ITYP=LDEL(1,KK) 172 : IDEP=LDEL(2,KK) 173 : IF (ITYP.GT.0) THEN 174 : IFEP=IDEP+KDFAC(1,ITYP)-1 175 : ELSE 176 : C Cas du polygone 177 : IFEP= IDEP+IPT1.NUM(/1)-1 178 : ENDIF 179 : 180 : DO 22 I=1,IPT1.NUM(/2) 181 : DO 22 J=IDEP,IFEP,IPAS 182 : NMIL=1 183 : N1=ICPR(IPT1.NUM(LFAC(J),I)) 184 : JSUIV=J+IPAS 185 : 186 : IF (JSUIV.GT.IFEP) JSUIV=IDEP 187 : 188 : N2=ICPR(IPT1.NUM(LFAC(JSUIV),I)) 189 : 190 : IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I) 191 : 192 : NI=N1 193 : NJ=N2 194 : 195 : IF (N1*N2.EQ.0) GOTO 32 196 : 197 : KSCOL=IPT1.ICOLOR(I) 198 : IPO=0 199 : 200 : 23 CONTINUE 201 : 24 DO 25 IK=1,NBCONR 202 : IF (KON(IK,NI,1).EQ.0) GOTO 26 203 : IF (KON(IK,NI,1).EQ.NJ) GOTO 29 204 : 25 CONTINUE 205 : 206 : IF (KON(NBCON,NI,1).EQ.0) GOTO 28 207 : NI=KON(NBCON,NI,1) 208 : GOTO 24 209 : 210 : 26 KON(IK,NI,1)=NJ 211 : KON(IK,NI,2)=NMIL 212 : KON(IK,NI,3)=KSCOL 213 : GOTO 29 214 : 215 : 28 ICHAIN=ICHAIN+1 216 : IF (ICHAIN.GE.NMAX) GOTO 32 217 : KON(NBCON,NI,1)=ICHAIN 218 : IK=1 219 : NI=ICHAIN 220 : GOTO 26 221 : 222 : 29 IF (IPO.EQ.1) GOTO 22 223 : NMIL=-NMIL 224 : NI=N2 225 : NJ=N1 226 : IPO=1 227 : GOTO 23 228 : 229 : 22 CONTINUE 230 : 21 CONTINUE 231 : 300 CONTINUE 232 : 233 : ENDIF 234 : 235 : IF (LISOUS(/1).NE.0) SEGDES IPT1 236 : 237 : 30 CONTINUE 238 : 239 : GOTO 31 240 : 240 : 32 CALL ERREUR(26) 241 : SEGSUP KON,ICPR 242 : SEGDES MELEME 243 : RETURN 244 : 245 : 31 CONTINUE 246 : IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1,2),I=1,NBCON), 247 : # J=1,NMAX) 248 : 1122 FORMAT(1X,14I5) 249 : 250 : SEGDES MELEME 251 : 252 : SEGINI IDCP 253 : 254 : DO 40 I=1,ICPR(/1) 255 : IF (ICPR(I).EQ.0) GOTO 40 256 : IDCP(ICPR(I))=I 257 : 40 CONTINUE 258 : 259 : SEGSUP ICPR 260 : ************************************************************************ 261 : 262 : * CREATION DE L'OBJET MAILLAGE 263 : IEL=0 264 : NBSOUS=0 265 : NBREF=0 266 : NBELEM=0 267 : 268 : 269 : 270 : C ****ON COMPTE LE NOMBRE D'ELEMENTS POUR ACTIVER LE SEGMENT 271 : 272 : DO 170 J=1,ITE 273 : JJ=J 274 : 275 : 179 CONTINUE 276 : DO 180 I=1,NBCONR 277 : M=KON(I,JJ,1) 278 : IF(M.LT.J) GOTO 180 279 : * IF (M.EQ.0) GOTO 170 280 : NBELEM=NBELEM+1 281 : 180 CONTINUE 282 : 283 : * IF (I.EQ.0) GOTO 170 284 : * IF (KON(NBCON-1,JJ,1).EQ.0) GOTO 170 285 : IF (KON(NBCON,JJ,1) .EQ. 0) GOTO 170 286 : JJ=KON(NBCON,JJ,1) 287 : GOTO 179 288 : 170 CONTINUE 289 : 290 : 291 : 292 : ** TEST VERIFIANT SI AU DEPART ON A DEJA DES POINTS,SEG2 OU SEG3 293 : IF (IOO.EQ.0) THEN 294 : * LE MAILLAGE EXISTE DEJA 295 : PRINT *,'*LE MAILLAGE EXISTE DEJA' 295 : CALL ECROBJ('MAILLAGE',IPT1) 296 : SEGDES MELEME 297 : RETURN 298 : ENDIF 299 : 299 : IF (NBELEM .EQ. 0) CALL ERREUR(26) 300 : IF (IERR .NE. 0) GOTO 64 301 : 302 : 303 : SEGINI MELEME 304 : ITYPEL=NBNN 305 : IEL=0 306 : 307 : 308 : C****ETABLISSEMENT DU MAILLAGE 309 : C****CONSTRUCTION DU TABLEAU NUM 310 : 311 : DO 100 J=1,ITE 312 : JJ=J 313 : 314 : 109 CONTINUE 315 : DO 110 I=1,NBCONR 316 : M=KON(I,JJ,1) 317 : * IF (M.EQ.0) GOTO 100 318 : IF (M.LT.J) GOTO 110 319 : IEL=IEL+1 320 : NUM(1,IEL)=IDCP(J) 321 : NUM(NBNN,IEL)=IDCP(M) 322 : ICOLOR(IEL)=KON(I,JJ,3) 323 : IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(I,JJ,2)) 324 : 110 CONTINUE 325 : 326 : * IF (I.EQ.0) GOTO 170 327 : * IF (KON(NBCON-1,JJ,1).EQ.0) GOTO 100 328 : IF (KON(NBCON,JJ,1).EQ.0) GOTO 100 329 : JJ=KON(NBCON,JJ,1) 330 : GOTO 109 331 : 100 CONTINUE 332 : 333 : 334 : SEGDES MELEME 334 : CALL ECROBJ('MAILLAGE',MELEME) 335 : 336 : * ON INSCRIT LE CONTOUR DANS LE MAILLAGE INITIAL 337 : 338 : * SEGACT IPT8 339 : 340 : * IF (IPT8.LISREF(/1).EQ.0) THEN 341 : * NBREF=1 342 : * NBNN=IPT8.NUM(/1) 343 : * NBELEM=IPT8.NUM(/2) 344 : * NBSOUS=IPT8.LISOUS(/1) 345 : * SEGADJ IPT8 346 : * IPT8.LISREF(1)=MELEME 347 : * ENDIF 348 : 349 : * SEGDES IPT8 350 : 351 : 64 CONTINUE 352 : SEGSUP KON,IDCP 353 : RETURN 354 : END 355 : 356 : 357 : 358 : 359 : 360 : 361 : 362 : 363 : 364 :
© Cast3M 2003 - All rights reserved.
Disclaimer