1 : C PRCONT SOURCE CHAT 07/10/29 21:25:46 5940 2 : C CE SOUS PROGRAMME RETROUVE LE CONTOUR D'UN OBJET 3 : C IL FONCTIONNE SUIVANT UN PRINCIPE DERIVE DES TRACES 4 : C 5 : SUBROUTINE PRCONT 6 : IMPLICIT INTEGER(I-N) 7 : -INC CCOPTIO 8 : -INC CCGEOME 9 : -INC SMELEME 10 : -INC SMCOORD 11 : character*4 lmot(1) 12 : data lmot/'NOID'/ 13 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 14 : SEGMENT IDCP(ITE) 15 : SEGMENT NTSEG(0) 16 : SEGMENT KON(NBCON,NMAX,3) 17 : INTEGER NBNN,COMPT,NNOEUD,NKON,NINT 18 : CHARACTER*8 CHAIN1 18 : call lirmot(lmot,1,imot,0) 18 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 19 : IF (IERR.NE.0) RETURN 20 : IPT8=MELEME 21 : SEGACT MELEME 22 : IF (LISREF(/1).EQ.1) THEN 23 : * LE CONTOUR EXISTE DEJA 24 : IPT1=LISREF(1) 24 : CALL ECROBJ('MAILLAGE',IPT1) 25 : SEGDES MELEME 26 : RETURN 27 : ENDIF 28 : SEGINI ICPR 29 : c 30 : ITE=0 31 : IPT1=MELEME 32 : DO 3 I=1,MAX(1,LISOUS(/1)) 33 : IF (LISOUS(/1).NE.0) THEN 34 : IPT1=LISOUS(I) 35 : SEGACT IPT1 36 : ENDIF 37 : K=IPT1.ITYPEL 38 : IF (K.NE.KSURF(K)) GOTO 8 39 : IDEP=NSPOS(K) 40 : IF (NBSOM(K).GT.0) THEN 41 : IFEP=IDEP+NBSOM(K)-1 42 : ELSE 43 : C Cas du polygone 44 : IFEP=IDEP+IPT1.NUM(/1)-1 45 : ENDIF 46 : IF (IFEP.LT.IDEP) GOTO 8 47 : DO 4 JJ=IDEP,IFEP 48 : J=IBSOM(JJ) 49 : DO 4 K=1,IPT1.NUM(/2) 50 : IPOIT=IPT1.NUM(J,K) 51 : IF (ICPR(IPOIT).NE.0) GOTO 7 52 : ITE=ITE+1 53 : ICPR(IPOIT)=ITE 54 : 7 CONTINUE 55 : 4 CONTINUE 56 : 8 CONTINUE 57 : IF (LISOUS(/1).NE.0) SEGDES IPT1 58 : 3 CONTINUE 59 : SEGDES MELEME 60 : IF (ITE.NE.0) GOTO 6 61 : SEGSUP ICPR 61 : CALL ERREUR(16) 62 : RETURN 63 : 6 CONTINUE 64 : C ITE EST LE NOMBRE DE POINTS A CONSIDERER ICPR LE TABLEAU 65 : C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS 66 : NBCON=7 67 : NBCONR=NBCON-1 68 : NMAX=(10*ITE)/NBCON 69 : SEGINI KON 70 : C MISE A ZERO DU TABLEAU KON 71 : DO 10 K=1,3 72 : DO 10 I=1,NMAX 73 : DO 10 J=1,NBCON 74 : 10 KON(J,I,K)=0 75 : C FABRICATION DU TABLEAU DES CONNECTIONS 76 : C 1 POINT FINAL 77 : C 2 POINT INTERMEDIAIRE EVENTUEL ET SENS 78 : NBNN=0 79 : COMPT=0 80 : ICHAIN=ITE 81 : SEGACT MELEME 82 : IPT1=MELEME 83 : DO 30 IO=1,MAX(1,LISOUS(/1)) 84 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO) 85 : SEGACT IPT1 86 : K=IPT1.ITYPEL 87 : IF (K.NE.KSURF(K)) GOTO 21 88 : C LE NOMBRE DE FACE EST 1 QUEL EST SON TYPE 89 : KK=LTEL(2,K) 90 : ITYP=LDEL(1,KK) 91 : IF (NBNN.NE.KDEGRE(K)) THEN 92 : NBNN=KDEGRE(K) 93 : COMPT=COMPT+1 94 : ENDIF 95 : IPAS=NBNN-1 96 : IDEP=LDEL(2,KK) 97 : IF (ITYP.NE.6) THEN 98 : IFEP=IDEP+KDFAC(1,ITYP)-1 99 : ELSE 100 : C Cas du polygone 101 : IFEP= IDEP+IPT1.NUM(/1)-1 102 : ENDIF 103 : DO 22 I=1,IPT1.NUM(/2) 104 : DO 22 J=IDEP,IFEP,IPAS 105 : NMIL=1 106 : N1=ICPR(IPT1.NUM(LFAC(J),I)) 107 : JSUIV=J+IPAS 108 : IF (JSUIV.GT.IFEP) JSUIV=IDEP 109 : N2=ICPR(IPT1.NUM(LFAC(JSUIV),I)) 110 : IF (IPAS.EQ.2) NMIL=IPT1.NUM(LFAC(J+1),I) 111 : NI=N1 112 : NJ=N2 113 : IF (N1*N2.EQ.0) GOTO 32 114 : KSCOL=IPT1.ICOLOR(I) 115 : IPO=0 116 : 23 CONTINUE 117 : KINT=1 118 : 120 CONTINUE 119 : 24 DO 25 K=KINT,NBCONR 120 : IF (KON(K,NI,1).EQ.0) GOTO 26 121 : IF (KON(K,NI,1).EQ.NJ) GOTO 27 122 : 25 CONTINUE 123 : IF (KON(NBCON,NI,1).EQ.0) GOTO 28 124 : NI=KON(NBCON,NI,1) 125 : GOTO 24 126 : 27 IF (ABS(KON(K,NI,2)).EQ.ABS(NMIL)) THEN 127 : KON(K,NI,1)=-1 128 : GOTO 29 129 : ELSE 130 : KINT=K+1 131 : GOTO 120 132 : ENDIF 133 : 26 KON(K,NI,1)=NJ 134 : KON(K,NI,2)=NMIL 135 : KON(K,NI,3)=KSCOL 136 : GOTO 29 137 : 28 ICHAIN=ICHAIN+1 138 : IF (ICHAIN.GE.NMAX) THEN 139 : NMAX = NMAX * 2 140 : SEGADJ KON 141 : ENDIF 142 : KON(NBCON,NI,1)=ICHAIN 143 : K=1 144 : NI=ICHAIN 145 : GOTO 26 146 : 29 IF (IPO.EQ.1) GOTO 22 147 : NMIL=-NMIL 148 : NI=N2 149 : NJ=N1 150 : IPO=1 151 : GOTO 23 152 : 22 CONTINUE 153 : 21 CONTINUE 154 : IF (LISOUS(/1).NE.0) SEGDES IPT1 155 : 30 CONTINUE 156 : GOTO 31 156 : 32 CALL ERREUR(26) 157 : SEGSUP KON,ICPR 158 : SEGDES MELEME 159 : RETURN 160 : 31 CONTINUE 161 : IF (COMPT.GT.1) THEN 161 : CALL ERREUR(-333) 162 : ENDIF 163 : IF (IIMPI.EQ.2)WRITE (IOIMP,1122) (((KON(I,J,K),K=1,2),I=1,NBCON 164 : # ),J=1,NMAX) 165 : 1122 FORMAT(1X,14I5) 166 : SEGDES MELEME 167 : SEGINI IDCP 168 : DO 40 I=1,ICPR(/1) 169 : IF (ICPR(I).EQ.0) GOTO 40 170 : IDCP(ICPR(I))=I 171 : 40 CONTINUE 172 : C 173 : C ON VERIFIE SI CHAQUE NOEUD DU CONTOUR EST BIEN RELIE UNIQUEMENT 174 : C A DEUX ELEMENTS 175 : C 176 : if( iimpi.ne.0) then 177 : NNOEUD=0 178 : CHAIN1='NODE' 179 : DO 70 NI=1,ITE 180 : if(icpr(ni).eq.0) go to 70 181 : NINT=NI 182 : NKON=0 183 : 72 CONTINUE 184 : DO 71 J=1,NBCONR 185 : IF (KON(J,NINT,1).EQ.0) GOTO 71 186 : IF (KON(J,NINT,1).NE.-1) THEN 187 : NKON=NKON+1 188 : ENDIF 189 : 71 CONTINUE 190 : IF (KON(NBCON,NINT,1).NE.0) THEN 191 : NINT=KON(NBCON,NINT,1) 192 : GOTO 72 193 : ENDIF 194 : IF (NKON.GT.2) THEN 195 : 196 : NNOEUD=NNOEUD+1 197 : JP1=IDCP(NI) 198 : * write(6,*) ' p1 ', Jp1 199 : nno=nnoeud 200 : IF (NNO.LE.9) THEN 201 : WRITE(CHAIN1(5:5),111)NNO 202 : ELSEif(NNO.LE.99) THEN 203 : WRITE(CHAIN1(5:6),222)NNO 204 : ELSEif(NNO.LE.999) THEN 205 : WRITE(CHAIN1(5:7),333)NNO 206 : ELSEif(NNO.LE.9999) THEN 207 : WRITE(CHAIN1(5:8),444)NNO 208 : ELSEif(NNO.LE.99999) THEN 209 : WRITE(CHAIN1(4:8),555)NNO 210 : ELSEif(NNO.LE.999999) THEN 211 : WRITE(CHAIN1(3:8),666)NNO 212 : ENDIF 213 : 111 FORMAT(I1) 214 : 222 FORMAT(I2) 215 : 333 format (i3) 216 : 444 format (i4) 217 : 555 format(i5) 218 : 666 format(i6) 218 : CALL NOMOBJ('POINT ',CHAIN1,JP1) 219 : MOTERR(1:8)=chain1 220 : INTERR(1)=NKON 220 : CALL ERREUR(-335) 221 : END IF 222 : 70 CONTINUE 223 : endif 224 : SEGSUP ICPR 225 : C 226 : C 227 : C CREATION DE L'OBJET CONTOUR. ON COMMENCE PAR COMPTER LENOMBRE D'ELEME 228 : C 229 : C Cas où le contour est un objet géométrique simple 230 : C (uniquement des seg2 ou uniquement des seg3) 231 : C 232 : IF (COMPT.EQ.1) THEN 233 : NBSOUS=0 234 : NBREF=0 235 : NBELEM=0 236 : DO 41 J=1,ITE 237 : JJ=J 238 : 43 DO 42 I=1,NBCONR 239 : IF (KON(I,JJ,1).LT.J) GOTO 42 240 : NBELEM=NBELEM+1 241 : 42 CONTINUE 242 : IF (KON(NBCON,JJ,1).EQ.0) GOTO 41 243 : JJ=KON(NBCON,JJ,1) 244 : GOTO 43 245 : 41 CONTINUE 246 : IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM 247 : 1111 FORMAT(' NOMBRE D''ELEMENTS DU CONTOUR : ',I6) 247 : IF (NBELEM.EQ.0.and.imot.eq.0) CALL ERREUR(26) 248 : IF (IERR.NE.0) GOTO 64 249 : SEGINI MELEME 250 : ITYPEL=NBNN 251 : IEL=0 252 : KAUX=1 253 : 50 K=KAUX 254 : KAUXR=KAUX 255 : 51 DO 52 KL=1,NBCONR 256 : ITRA=KON(KL,K,1) 257 : IF (ITRA.EQ.-1) GOTO 52 258 : IF (ITRA.EQ.0) GOTO 53 259 : IF (KON(KL,K,2).LT.0) GOTO 52 260 : GOTO 54 261 : 52 CONTINUE 262 : K=KON(NBCON,K,1) 263 : IF (K.NE.0) GOTO 51 264 : 53 KAUX=KAUX+1 265 : IF (KAUX.EQ.ITE+1) GOTO 63 266 : GOTO 50 267 : 54 KPRESS=KAUXR 268 : GOTO 55 269 : 57 KL=1 270 : 55 DO 56 L=KL,NBCONR 271 : M=KON(L,K,1) 272 : IF (M.EQ.0) GOTO 53 273 : IF (M.EQ.-1) GOTO 56 274 : GOTO 58 275 : 56 CONTINUE 276 : K=KON(NBCON,K,1) 277 : IF (K.EQ.0) GOTO 53 278 : GOTO 57 279 : 58 IEL=IEL+1 280 : NUM(1,IEL)=IDCP(KPRESS) 281 : NUM(NBNN,IEL)=IDCP(M) 282 : ICOLOR(IEL)=KON(L,K,3) 283 : IF (NBNN.EQ.3) NUM(2,IEL)=ABS(KON(L,K,2)) 284 : KON(L,K,1)=-1 285 : M1=M 286 : 59 DO 60 L=1,NBCONR 287 : IF (KON(L,M1,1).EQ.0) GOTO 62 288 : IF (KON(L,M1,1).EQ.KPRESS) GOTO 61 289 : 60 CONTINUE 290 : M1=KON(NBCON,M1,1) 291 : IF (M1.EQ.0) GOTO 62 292 : GOTO 59 293 : 61 KON(L,M1,1)=-1 294 : 62 KPRESS=M 295 : K=KPRESS 296 : GOTO 57 297 : 63 CONTINUE 298 : SEGDES MELEME 298 : CALL ECROBJ('MAILLAGE',MELEME) 299 : * ON INSCRIT LE CONTOUR DANS LE MAILLAGE INITIAL 300 : SEGACT IPT8 301 : IF (IPT8.LISREF(/1).EQ.0) THEN 302 : NBREF=1 303 : NBNN=IPT8.NUM(/1) 304 : NBELEM=IPT8.NUM(/2) 305 : NBSOUS=IPT8.LISOUS(/1) 306 : SEGADJ IPT8 307 : IPT8.LISREF(1)=MELEME 308 : ENDIF 309 : SEGDES IPT8 310 : C 311 : C Cas où le contour est objet géométrique complexe 312 : C 313 : C 314 : ELSE 315 : NBSOUS=2 316 : NBREF=0 317 : NBELEM=0 318 : SEGINI MELEME 319 : NBSOUS=0 320 : NBREF=0 321 : NBELEM=0 322 : DO 141 J=1,ITE 323 : JJ=J 324 : 143 DO 142 I=1,NBCONR 325 : IF (KON(I,JJ,1).LT.J) GOTO 142 326 : IF (ABS(KON(I,JJ,2)).EQ.1) GOTO 142 327 : NBELEM=NBELEM+1 328 : 142 CONTINUE 329 : IF (KON(NBCON,JJ,1).EQ.0) GOTO 141 330 : JJ=KON(NBCON,JJ,1) 331 : GOTO 143 332 : 141 CONTINUE 333 : IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM 334 : IF (IERR.NE.0) GOTO 64 335 : NBNN=3 336 : SEGINI IPT3 337 : IPT3.ITYPEL=NBNN 338 : IEL=0 339 : KAUX=1 340 : 150 K=KAUX 341 : KAUXR=KAUX 342 : 151 DO 152 KL=1,NBCONR 343 : IF (ABS(KON(KL,K,2)).EQ.1) GOTO 152 344 : ITRA=KON(KL,K,1) 345 : IF (ITRA.EQ.-1) GOTO 152 346 : IF (ITRA.EQ.0) GOTO 153 347 : IF (KON(KL,K,2).LT.0) GOTO 152 348 : GOTO 154 349 : 152 CONTINUE 350 : K=KON(NBCON,K,1) 351 : IF (K.NE.0) GOTO 151 352 : 153 KAUX=KAUX+1 353 : IF (KAUX.EQ.ITE+1) GOTO 163 354 : GOTO 150 355 : 154 KPRESS=KAUXR 356 : GOTO 155 357 : 157 KL=1 358 : 155 DO 156 L=KL,NBCONR 359 : IF (ABS(KON(L,K,2)).EQ.1) GOTO 156 360 : M=KON(L,K,1) 361 : IF (M.EQ.0) GOTO 153 362 : IF (M.EQ.-1) GOTO 156 363 : IF (KON(L,K,2).LT.0) GOTO 156 364 : GOTO 158 365 : 156 CONTINUE 366 : K=KON(NBCON,K,1) 367 : IF (K.EQ.0) GOTO 153 368 : GOTO 157 369 : 158 IEL=IEL+1 370 : IPT3.NUM(1,IEL)=IDCP(KPRESS) 371 : IPT3.NUM(NBNN,IEL)=IDCP(M) 372 : IPT3.ICOLOR(IEL)=KON(L,K,3) 373 : IPT3.NUM(2,IEL)=ABS(KON(L,K,2)) 374 : KON(L,K,1)=-1 375 : M1=M 376 : 159 DO 160 L=1,NBCONR 377 : IF (KON(L,M1,1).EQ.0) GOTO 162 378 : IF (KON(L,M1,1).EQ.KPRESS) GOTO 161 379 : 160 CONTINUE 380 : M1=KON(NBCON,M1,1) 381 : IF (M1.EQ.0) GOTO 162 382 : GOTO 159 383 : 161 KON(L,M1,1)=-1 384 : 162 KPRESS=M 385 : K=KPRESS 386 : GOTO 157 387 : 163 CONTINUE 388 : LISOUS(1)=IPT3 389 : SEGDES IPT3 390 : NBSOUS=0 391 : NBREF=0 392 : NBELEM=0 393 : DO 241 J=1,ITE 394 : JJ=J 395 : 243 DO 242 I=1,NBCONR 396 : IF (KON(I,JJ,1).LT.J) GOTO 242 397 : IF (ABS(KON(I,JJ,2)).NE.1) GOTO 242 398 : NBELEM=NBELEM+1 399 : 242 CONTINUE 400 : IF (KON(NBCON,JJ,1).EQ.0) GOTO 241 401 : JJ=KON(NBCON,JJ,1) 402 : GOTO 243 403 : 241 CONTINUE 404 : IF (IIMPI.NE.0) WRITE(IOIMP,1111) NBELEM 405 : IF (IERR.NE.0) GOTO 64 406 : NBNN=2 407 : SEGINI IPT2 408 : IPT2.ITYPEL=NBNN 409 : IEL=0 410 : KAUX=1 411 : 250 K=KAUX 412 : KAUXR=KAUX 413 : 251 DO 252 KL=1,NBCONR 414 : IF (ABS(KON(KL,K,2)).NE.1) GOTO 252 415 : ITRA=KON(KL,K,1) 416 : IF (ITRA.EQ.-1) GOTO 252 417 : IF (ITRA.EQ.0) GOTO 253 418 : IF (KON(KL,K,2).LT.0) GOTO 252 419 : GOTO 254 420 : 252 CONTINUE 421 : K=KON(NBCON,K,1) 422 : IF (K.NE.0) GOTO 251 423 : 253 KAUX=KAUX+1 424 : IF (KAUX.EQ.ITE+1) GOTO 263 425 : GOTO 250 426 : 254 KPRESS=KAUXR 427 : GOTO 255 428 : 257 KL=1 429 : 255 DO 256 L=KL,NBCONR 430 : IF (ABS(KON(L,K,2)).NE.1) GOTO 256 431 : M=KON(L,K,1) 432 : IF (M.EQ.0) GOTO 253 433 : IF (M.EQ.-1) GOTO 256 434 : IF (KON(L,K,2).LT.0) GOTO 256 435 : GOTO 258 436 : 256 CONTINUE 437 : K=KON(NBCON,K,1) 438 : IF (K.EQ.0) GOTO 253 439 : GOTO 257 440 : 258 IEL=IEL+1 441 : IPT2.NUM(1,IEL)=IDCP(KPRESS) 442 : IPT2.NUM(NBNN,IEL)=IDCP(M) 443 : IPT2.ICOLOR(IEL)=KON(L,K,3) 444 : KON(L,K,1)=-1 445 : M1=M 446 : 259 DO 260 L=1,NBCONR 447 : IF (KON(L,M1,1).EQ.0) GOTO 262 448 : IF (KON(L,M1,1).EQ.KPRESS) GOTO 261 449 : 260 CONTINUE 450 : M1=KON(NBCON,M1,1) 451 : IF (M1.EQ.0) GOTO 262 452 : GOTO 259 453 : 261 KON(L,M1,1)=-1 454 : 262 KPRESS=M 455 : K=KPRESS 456 : GOTO 257 457 : 263 CONTINUE 458 : LISOUS(2)=IPT2 459 : SEGDES IPT2 460 : SEGDES MELEME 460 : CALL ECROBJ('MAILLAGE',MELEME) 461 : SEGACT IPT8 462 : IF (IPT8.LISREF(/1).EQ.0) THEN 463 : NBREF=1 464 : NBNN=IPT8.NUM(/1) 465 : NBELEM=IPT8.NUM(/2) 466 : NBSOUS=IPT8.LISOUS(/1) 467 : SEGADJ IPT8 468 : IPT8.LISREF(1)=MELEME 469 : ENDIF 470 : SEGDES IPT8 471 : ENDIF 472 : 64 CONTINUE 473 : SEGSUP KON,IDCP 474 : RETURN 475 : END 476 : 477 : 478 : 479 : 480 : 481 : 482 : 483 : 484 : 485 : 486 : 487 : 488 : 489 : 490 : 491 : 492 : 493 :
© Cast3M 2003 - All rights reserved.
Disclaimer