1 : C J3FAFA SOURCE CHAT 05/01/13 00:46:41 5004 2 : SUBROUTINE J3FAFA(WWORK1,WWORK2,TOL,IRET,ICAS,VWORK1,VWORK2) 3 : C---------------------------------------------------- 4 : C TRAITEMENANT DU FACE A FACE (2D) 5 : C 6 : C VWORK1: NOUVELLES FACES DEJA TRAITEES 7 : C VWORK2: NOUVELLES FACES A TRAITEES 8 : C 9 : C CODE IST(1,I): 0 point non traite 10 : C 1 est sur le segment IST(2,I) 11 : C 2 est sur les segments IST(2,I) et IST(3,I) 12 : C -1 est a l'interieur 13 : C -2 est a l'exterieur 14 : C 15 : C CODE CRO(J,I): 1 cote sur le segment 16 : C -1 cote interieur 17 : C -2 cote exterieur 18 : C 19 : C PP 6/97 20 : C Pierre Pegon/JRC Ispra 21 : C---------------------------------------------------- 22 : C 23 : IMPLICIT INTEGER(I-N) 24 : IMPLICIT REAL*8(A-H,O-Z) 25 : -INC CCOPTIO 26 : SEGMENT VWORK 27 : INTEGER FWWORK(NFACE) 28 : ENDSEGMENT 29 : POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK 30 : C 31 : SEGMENT WWORK 32 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 33 : INTEGER FWORK 34 : INTEGER TWORK(NTROU) 35 : ENDSEGMENT 36 : POINTEUR WWORK1.WWORK,WWORK2.WWORK 37 : C 38 : SEGMENT WORK 39 : REAL*8 XYC(2,NPTO) 40 : INTEGER IST(3,NPTO) 41 : REAL*8 DENS(NPTO) 42 : INTEGER JUN 43 : ENDSEGMENT 44 : POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK 45 : C 46 : SEGMENT JUNC 47 : INTEGER CRO(2,NPTO) 48 : ENDSEGMENT 49 : C 50 : LOGICAL LAINB,LAOUB,LAONB,LACUB,LBINA,LBOUA,LBONA 51 : LOGICAL LCAINB,LCAOUB,LCAONB,LCBINA,LCBOUA,LCBONA 52 : LOGICAL LPLAN 53 : C 54 : IF (IIMPI.EQ.1789)THEN 55 : WRITE(IOIMP,*)'>>> On entre dans j3fafa <<<' 56 : ENDIF 57 : C 58 : VWORK1=0 59 : VWORK2=0 60 : IRET=0 61 : C 62 : C ON REGARDE SI LES FACES SONT DANS LE MEME PLAN 63 : C SI OUI, ON ALIGNE LES POINTS 64 : C SI NON, ON SORT AVEC UN CAS 1 65 : C 65 : CALL J3COPL(WWORK1,WWORK2,LPLAN,TOL) 66 : IF (.NOT.LPLAN)THEN 67 : ICAS=1 68 : IF (IIMPI.EQ.1789)THEN 69 : WRITE(IOIMP,*)' >>> traitement de 2 faces non coplanaires <<<' 70 : ENDIF 71 : RETURN 72 : ENDIF 73 : IF (IIMPI.EQ.1789)THEN 74 : WRITE(IOIMP,*)' >>> face A <<<' 74 : CALL J3LIWW(WWORK1) 75 : WRITE(IOIMP,*)' >>> face B <<<' 75 : CALL J3LIWW(WWORK2) 76 : ENDIF 77 : C 78 : C ON COMMENCE PAR TRAITER LES CONTOURS EXTERIEURS 79 : C 80 : WORK1=WWORK1.FWORK 81 : WORK2=WWORK2.FWORK 81 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 82 : IF (IRET.GT.0)THEN 83 : RETURN 84 : ENDIF 84 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 85 : IF (IRET.GT.0)THEN 86 : RETURN 87 : ENDIF 88 : C 89 : C ON REGARDE SI 1 POINT DE A EST STRICTEMENT DANS B OU HORS DE B 90 : C OU SUR B 91 : C 92 : NPTO1=WORK1.XYC(/2) 92 : CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) 93 : C 94 : C ON REGARDE SI 1 POINT DE B EST STRICTEMENT DANS A OU HORS DE A 95 : C OU SUR A 96 : C 97 : NPTO2=WORK2.XYC(/2) 97 : CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) 98 : C 99 : C ON S'OCCUPE TOUT D'ABORD DU CAS OU A ET B SONT COMPLETEMENT DISJOINTS 100 : C ==> ON ELIMINE LA SEULE POSSIBILITE DE CAS 3 STRICT ET UNE DE CAS 1 ET 2 101 : C 102 : LACUB=.FALSE. 103 : IF(LAOUB.AND.(.NOT.LAONB))THEN 104 : IF(LAINB)THEN 105 : IRAISO=1 106 : GOTO 9999 107 : ENDIF 108 : IF(LBINA)THEN 109 : IF(LBOUA)THEN 110 : IRAISO=2 111 : GOTO 9999 112 : ENDIF 113 : GOTO 3 114 : ELSE 115 : IF(.NOT.LBOUA)THEN 116 : IRAISO=3 117 : GOTO 9999 118 : ENDIF 119 : GOTO 1 120 : ENDIF 121 : ENDIF 122 : C 123 : IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN 124 : IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN 125 : IRAISO=4 126 : GOTO 9999 127 : ENDIF 128 : GOTO 2 129 : ENDIF 130 : C 131 : C POUR CONTINUER IL FAUT SAVOIR VRAIMENT SI ON COUPE 132 : C 132 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 133 : IF (IRET.GT.0)THEN 134 : RETURN 135 : ENDIF 136 : JUNC=WORK1.JUN 136 : CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) 137 : LACUB=LCAINB.AND.LCAOUB 138 : C 139 : C ET SI ON RECOUPE! 140 : C 140 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 141 : IF (IRET.GT.0)THEN 142 : RETURN 143 : ENDIF 144 : JUNC=WORK2.JUN 144 : CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) 145 : C 146 : C ON FINIT LE CAS 1 147 : C 148 : IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)GOTO 1 149 : C 150 : C ON FINIT LE CAS 2 151 : C 152 : IF(.NOT.LCAOUB) GOTO 2 153 : C 154 : C ON S'OCCUPE DU CAS 4 155 : C 156 : IF(LACUB)GOTO 4 157 : C 158 : C ON S'OCCUPE DU 4 "TANGENT" ET DU "FAUX" 3 159 : C 160 : IF((.NOT.LCAINB).AND.(.NOT.LCBOUA).AND.LAONB)THEN 161 : IF(NAONB.EQ.1)THEN 162 : GOTO 3 163 : ELSE 164 : GOTO 4 165 : ENDIF 166 : ENDIF 167 : C 168 : 169 : IRAISO=5 170 : GOTO 9999 171 : C 172 : C CAS NO. 1: ON NE FAIT RIEN 173 : C 174 : 1 ICAS=1 175 : C 176 : IF (IIMPI.EQ.1789)THEN 177 : WRITE(IOIMP,*)' >>> traitement d"un cas no.1 <<<' 178 : ENDIF 179 : C 180 : RETURN 181 : C 182 : C CAS NO. 2: ON CONTROLE LES TROUS 183 : C 184 : 2 ICAS=2 185 : C 186 : IF (IIMPI.EQ.1789)THEN 187 : WRITE(IOIMP,*)' >>> traitement d"un cas no.2 <<<' 188 : ENDIF 189 : C 190 : NTROU1=WWORK1.TWORK(/1) 191 : NTROU2=WWORK2.TWORK(/1) 192 : IF(NTROU1.NE.0)THEN 193 : WRITE(IOIMP,*)'CAS 2: face A avec trrrou' 194 : IRAISO=21 195 : GOTO 9999 196 : ENDIF 197 : C 198 : C SI PAS DE TROU DANS B... ON VERIFIE SI A N'EST PAS EGAL A B 199 : C ET SI OUI ON LE REND IDENTIQUE 200 : C 201 : IF(NTROU2.EQ.0)THEN 202 : IF(NTROU1.EQ.0)THEN 202 : CALL J3IDEN(WORK1,WORK2,TOL) 203 : WWORK1.FWORK=WORK1 204 : RETURN 205 : ELSE 206 : IRAISO=22 207 : GOTO 9999 208 : ENDIF 209 : C 210 : C ... SINON ON REMPLACE B PAR LES TROUS DE B 211 : C 212 : ELSE 213 : DO 20 IE1=1,NTROU2 214 : WORK2=WWORK2.TWORK(IE1) 214 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 215 : IF (IRET.GT.0)THEN 216 : RETURN 217 : ENDIF 217 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 218 : IF (IRET.GT.0)THEN 219 : RETURN 220 : ENDIF 221 : C 222 : C 2 SEULS CAS A VERIFIER: CAS 1 DISJOINT (A SANS TROU) 223 : C CAS 2 224 : C SINON ERREUR 225 : C 226 : NPTO1=WORK1.XYC(/2) 226 : CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) 227 : C 228 : NPTO2=WORK2.XYC(/2) 228 : CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) 229 : C 230 : IF(LAOUB.AND.(.NOT.LAONB))THEN 231 : IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA).OR.(NTROU1.NE.0))THEN 232 : IRAISO=23 233 : GOTO 9999 234 : ENDIF 235 : GOTO 20 236 : ENDIF 237 : C 238 : IF((.NOT.LAOUB).AND.(.NOT.LAONB))GOTO 20 239 : C 239 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 240 : IF (IRET.GT.0)THEN 241 : RETURN 242 : ENDIF 243 : JUNC=WORK1.JUN 243 : CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) 244 : LACUB=LCAINB.AND.LCAOUB 245 : IF(.NOT.LCAOUB) GOTO 20 246 : IRAISO=24 247 : GOTO 9999 248 : 20 CONTINUE 249 : ENDIF 250 : C 251 : RETURN 252 : C 253 : C CAS NO. 3: D'ABORD ON VERIFIE QUE B N'A PAS DE TROU 254 : C 255 : 3 ICAS=3 256 : C 257 : IF (IIMPI.EQ.1789)THEN 258 : WRITE(IOIMP,*)' >>> traitement d"un cas no.3 <<<' 259 : ENDIF 260 : C 261 : NTROU2=WWORK2.TWORK(/1) 262 : IF(NTROU2.NE.0)THEN 263 : IRAISO=31 264 : GOTO 9999 265 : ENDIF 266 : C 267 : C ON CREE UNE NOUVELLE FACE (RECOPIE DE WORK2) 268 : C 269 : NFACE=1 270 : SEGINI,VWORK1 271 : SEGINI,WWORK=WWORK2 272 : VWORK1.FWWORK(1)=WWORK 273 : SEGINI,WORK=WORK2 274 : JUN=0 275 : FWORK=WORK 276 : C 277 : C ON AJOUTE ENSUITE UN TROU A A QUE L'ON MET EN PREMIERE 278 : C POSITION (ON INVERSE LA NUMEROTATION DE B) 279 : C 280 : NTROU1=WWORK1.TWORK(/1)+1 281 : NTROU=NTROU1 282 : SEGADJ,WWORK1 283 : IF (NTROU1.GT.1)THEN 284 : DO IE1=NTROU1,2,-1 285 : WWORK1.TWORK(IE1)=WWORK1.TWORK(IE1-1) 286 : ENDDO 287 : ENDIF 288 : C 289 : SEGINI,WORK1=WORK2 290 : WORK1.JUN=0 291 : NPTO1=NPTO2 291 : CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET) 292 : IF(IRET.NE.0)THEN 293 : IRAISO=32 294 : GOTO 9999 295 : ENDIF 296 : WWORK1.TWORK(1)=WORK1 297 : C 298 : C SI UN SEUL TROU ON SORT 299 : C 300 : IF(NTROU1.EQ.1)RETURN 301 : C 302 : C ON VERIFIE QUE CE NOUVEAU TROU EST UN CAS 1 VIS A VIS DES 303 : C AUTRES TROUS DE A (ATTENTION, ON COMPTE LE NB DE CAS AVEC 304 : C CONTACT EN 1 SEUL POINT) 305 : C 306 : DO 30 IE1=2,NTROU1 307 : WORK2=WWORK1.TWORK(IE1) 308 : IF(WORK2.EQ.0)GOTO 30 308 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 309 : IF (IRET.GT.0)THEN 310 : RETURN 311 : ENDIF 311 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 312 : IF (IRET.GT.0)THEN 313 : RETURN 314 : ENDIF 315 : C 316 : NPTO1=WORK1.XYC(/2) 316 : CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) 317 : C 318 : NPTO2=WORK2.XYC(/2) 318 : CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) 319 : C 320 : C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT) 321 : C 322 : IF(LAOUB.AND.(.NOT.LAONB))THEN 323 : IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN 324 : IRAISO=33 325 : GOTO 9999 326 : ENDIF 327 : GOTO 30 328 : ENDIF 329 : C 330 : C A-T-ON UN CAS 1 AVEC CONTACT ? (SI OUI ON COALESCE) 331 : C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT)) 332 : C WARNING UN CAS 2 SEMBLE LICITE!!!!!!!! 333 : C 334 : IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN 335 : IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN 336 : IRAISO=34 337 : GOTO 9999 338 : ENDIF 339 : SEGSUP,WORK,WWORK,VWORK1,WORK1 340 : WWORK1.TWORK(1)=0 341 : ICAS=1 342 : GOTO 31 343 : ENDIF 344 : C 344 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 345 : IF (IRET.GT.0)THEN 346 : RETURN 347 : ENDIF 348 : JUNC=WORK1.JUN 349 : NPTO1=WORK1.XYC(/2) 349 : CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) 350 : LACUB=LCAINB.AND.LCAOUB 351 : C 351 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 352 : IF (IRET.GT.0)THEN 353 : RETURN 354 : ENDIF 355 : NPTO2=WORK2.XYC(/2) 356 : JUNC=WORK2.JUN 356 : CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) 357 : C 358 : IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN 359 : IF(NAONB.EQ.1)GOTO 30 359 : CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET) 360 : IF(IRET.GT.0)THEN 361 : RETURN 362 : ELSE 363 : JUNC=WORK2.JUN 364 : IF(JUNC.NE.0)SEGSUP,JUNC 365 : SEGSUP,WORK2 366 : WWORK1.TWORK(1)=WORK1 367 : WWORK1.TWORK(IE1)=0 368 : ENDIF 369 : C 370 : C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT 371 : C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA 372 : C NOUVELLE FACE 373 : C 374 : IF(NFACEA.GT.0)THEN 374 : CALL J3HEAD(WWORK1,VWORK) 374 : CALL J3COAK(WWORK1,VWORK,TOL,IRET) 374 : CALL J3VPLU(VWORK2,VWORK) 375 : ENDIF 376 : ELSE 377 : C 378 : C ON EJECTE UN CAS 2 AVEC CONTACT QUI EST LICITE 379 : C 380 : IF (.NOT.LCAOUB)THEN 381 : SEGSUP,WORK,WWORK,VWORK1,WORK1 382 : WWORK1.TWORK(1)=0 383 : ICAS=1 384 : GOTO 31 385 : ENDIF 386 : IRAISO=35 387 : GOTO 9999 388 : ENDIF 389 : 30 CONTINUE 390 : C 391 : C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE 392 : C 392 : 31 CALL J3REDU(WWORK1) 393 : C 394 : C 395 : RETURN 396 : C 397 : C CAS NO. 4: ON CONTROLE LES TROU DE B 398 : C 399 : 4 ICAS=4 400 : C 401 : IF (IIMPI.EQ.1789)THEN 402 : WRITE(IOIMP,*)' >>> traitement d"un cas no.4 <<<' 403 : ENDIF 404 : C 405 : NTROU2=WWORK2.TWORK(/1) 406 : IF(NTROU2.NE.0)THEN 407 : IRAISO=41 408 : GOTO 9999 409 : ENDIF 410 : C 411 : C ON COUPE A PAR B ET ON GARDE LA PARTIE INTERIEURE (SANS 412 : C REDISTRIBUTION DES TROU) DANS VWORK1. 413 : C 413 : CALL J3COUP(WWORK1,WORK2,VWORK1,VWORK,0,TOL,IRET) 414 : IF (IRET.GT.0)THEN 415 : IRAISO=42 416 : GOTO 9999 417 : ENDIF 417 : CALL J3HEAD(WWORK1,VWORK1) 418 : C 419 : C S'IL N'Y A PAS DE TROU DANS A ON SAUTE DIRECTEMENT 420 : C APRES LA PHASE DE SECONDE COUPE 421 : C 422 : NTROU1=WWORK1.TWORK(/1) 423 : IF(NTROU1.EQ.0)GOTO 45 423 : CALL J3DET1(VWORK) 424 : C 425 : C S'IL Y A DES TROU DANS A, ILS DOIVENT ETRE DES CAS 1 VIS A VIS 426 : C DE B ET EVENTUELLEMENT COHALESCER AVEC B ET DONC ON COMMENCE PAR 427 : C INVERSER B DANS WORK1, ENSUITE ON CONTINUE COMME DANS CAS 3 428 : C 429 : SEGINI,WORK1=WORK2 430 : WORK1.JUN=0 431 : NPTO1=NPTO2 431 : CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET) 432 : IF(IRET.NE.0)THEN 433 : RETURN 434 : ENDIF 435 : C 436 : C WARNING: ON PROCEDE "B PAR RAPPORT A A" POUR FINIR AVEC LE MEME NB DE 437 : C POINTS EN CAS DE COALESCENCE" 438 : C 439 : DO 40 IE1=1,NTROU1 440 : WORK2=WWORK1.TWORK(IE1) 441 : IF(WORK2.EQ.0)GOTO 40 441 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 442 : IF (IRET.GT.0)THEN 443 : RETURN 444 : ENDIF 444 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 445 : IF (IRET.GT.0)THEN 446 : RETURN 447 : ENDIF 448 : C 449 : NPTO1=WORK1.XYC(/2) 449 : CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB) 450 : C 451 : NPTO2=WORK2.XYC(/2) 451 : CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA) 452 : C 453 : C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT) 454 : C 455 : IF(LAOUB.AND.(.NOT.LAONB))THEN 456 : IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN 457 : IRAISO=43 458 : GOTO 9999 459 : ENDIF 460 : GOTO 40 461 : ENDIF 462 : C 463 : C A-T-ON UN CAS 1 AVEC CONTACT? (SI OUI ON COALESCE) 464 : C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT) 465 : C 466 : IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN 467 : IRAISO=43 468 : GOTO 9999 469 : ENDIF 470 : C 470 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 471 : IF (IRET.GT.0)THEN 472 : RETURN 473 : ENDIF 474 : JUNC=WORK1.JUN 475 : NPTO1=WORK1.XYC(/2) 475 : CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB) 476 : LACUB=LCAINB.AND.LCAOUB 477 : C 477 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 478 : IF (IRET.GT.0)THEN 479 : RETURN 480 : ENDIF 481 : NPTO2=WORK2.XYC(/2) 482 : JUNC=WORK2.JUN 482 : CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA) 483 : C 484 : IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN 485 : IF(NAONB.EQ.1)GOTO 40 485 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 485 : CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET) 486 : IF(IRET.GT.0)THEN 487 : RETURN 488 : ELSE 489 : JUNC=WORK2.JUN 490 : IF(JUNC.NE.0)SEGSUP,JUNC 491 : SEGSUP,WORK2 492 : WWORK1.TWORK(IE1)=0 493 : ENDIF 494 : 495 : C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT 496 : C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA 497 : C NOUVELLE FACE 498 : C 499 : IF(NFACEA.GT.0)THEN 499 : CALL J3HEAD(WWORK1,VWORK) 499 : CALL J3COAK(WWORK1,VWORK,TOL,IRET) 499 : CALL J3VPLU(VWORK2,VWORK) 500 : ENDIF 501 : ELSE 502 : IRAISO=44 503 : GOTO 9999 504 : ENDIF 505 : 40 CONTINUE 506 : C 507 : C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE 508 : C 508 : CALL J3REDU(WWORK1) 509 : C 510 : C ON INVERSE MAINTENANT LA NUMEROTATION DE WORK1 DANS WORK2 511 : C 512 : WORK2=WORK1 513 : NPTO2=WORK2.XYC(/2) 513 : CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,1,TOL,IRET) 513 : C PP? CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,-1,TOL,IRET) 514 : IF(IRET.NE.0)THEN 515 : IRAISO=45 516 : GOTO 9999 517 : ENDIF 518 : C 519 : C ON REMET A DANS WORK1 ET ON REFAIT LES TESTS 520 : C 521 : WORK1=WWORK1.FWORK 521 : CALL J3COTO(WORK2,WORK1,TOL,IRET) 522 : IF(IRET.NE.0)THEN 523 : IRAISO=46 524 : GOTO 9999 525 : ENDIF 525 : CALL J3COTO(WORK1,WORK2,TOL,IRET) 526 : IF(IRET.NE.0)THEN 527 : IRAISO=47 528 : GOTO 9999 529 : ENDIF 529 : CALL J3JUNC(WORK1,WORK2,TOL,IRET) 530 : IF(IRET.NE.0)THEN 531 : IRAISO=48 532 : GOTO 9999 533 : ENDIF 534 : C 535 : C C'EST ICI QUE L'ON RE-COUPE (A EST DANS WORK1 ET B COHALESCE 536 : C DANS WORK2) 537 : C 538 : C ON REGARDE D'ABORD EGALEMENT COMMENT B COUPE A 539 : C 539 : CALL J3JUNC(WORK2,WORK1,TOL,IRET) 540 : IF(IRET.NE.0)THEN 541 : IRAISO=49 542 : GOTO 9999 543 : ENDIF 544 : C 545 : C PUIS ON COUPE (ON NE S'INTERESSE QUE A LA PARTIE 546 : C EXTERIEURE VWORK) 547 : C 548 : WWORK1.FWORK=WORK1 548 : CALL J3COUP(WWORK1,WORK2,VWDUMM,VWORK,1,TOL,IRET) 548 : CALL J3DET1(VWDUMM) 549 : C 549 : 45 CALL J3HEAD(WWORK1,VWORK) 549 : CALL J3VPLU(VWORK2,VWORK) 550 : C 551 : RETURN 552 : C 553 : C CONFIGURATION IMPOSSIBLE 554 : C 555 : 9999 CONTINUE 556 : WRITE(IOIMP,*)' J3FAFA: CONFIGURATION IMPOSSIBLE NO.',IRAISO 557 : IRET=IRET+1 558 : RETURN 559 : C 560 : END 561 : 562 :
© Cast3M 2003 - All rights reserved.
Disclaimer