1 : C GENJO3 SOURCE CHAT 07/10/29 21:20:08 5940 2 : SUBROUTINE GENJO3 3 : C-------------------------------------------------------------------- 4 : C 5 : C MAIL1 = GENJ MAIL2 FLOT1; 6 : C 7 : C MAIL1 : MAILLAGE DE JOT3 OU JOI4 8 : C MAIL2 : MAILLAGE DE CUB8, PRI6, PYR5 ET/OU TET4 9 : C FLOT1 : TOLERANCE 10 : C 11 : C Pierre Pegon/JRC Ispra 12 : C-------------------------------------------------------------------- 13 : IMPLICIT INTEGER(I-N) 14 : IMPLICIT REAL*8 (A-H,O-Z) 15 : C 16 : -INC CCOPTIO 17 : -INC SMELEME 18 : -INC SMCOORD 19 : -INC CCGEOME 20 : -INC SMLENTI 21 : -INC SMLREEL 22 : C 23 : SEGMENT,JO4GEN 24 : INTEGER P4(4,NCOT4) 25 : INTEGER SZ4(NCOT4), NELM4(NCOT4) 26 : INTEGER FLA4(NCOT4) 27 : ENDSEGMENT 28 : POINTEUR JO4GE1.JO4GEN 29 : C 30 : SEGMENT,JO3GEN 31 : INTEGER P3(3,NCOT3) 32 : INTEGER SZ3(NCOT3), NELM3(NCOT3) 33 : INTEGER FLA3(NCOT3) 34 : ENDSEGMENT 35 : POINTEUR JO3GE1.JO3GEN 36 : C 37 : LOGICAL GENTST 38 : DIMENSION FAC1(3,4),FAC2(3,4),BAR1(3),BAR2(3) 39 : C 40 : IF(IIMPI.EQ.1790)THEN 41 : WRITE(IOIMP,*)'GENJO3: On entre dans la subroutine' 42 : ENDIF 43 : C 43 : CALL LIROBJ('MAILLAGE',IPT1,1,IRET) 44 : IF(IERR.NE.0) RETURN 44 : CALL LIRREE(XTOL,1,IRET) 45 : IF(IERR.NE.0) RETURN 46 : XTOL2=XTOL**2 47 : C 48 : C VERIFICATION DE LA DIMENSION 49 : C 50 : IF (IDIM.NE.3)THEN 51 : WRITE(IOIMP,*)'GENJO3: on n"est pas en 3D' 52 : RETURN 53 : ENDIF 54 : C 55 : C VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT CUB8, PRI6, 56 : C PYR5 ET TET4) 57 : C ET CALCUL DU NOMBRE DE COTES 58 : C 59 : NCOT4=0 60 : NCOT3=0 61 : SEGACT,IPT1 62 : NBSOUS=IPT1.LISOUS(/1) 63 : DO IE1=1,MAX(NBSOUS,1) 64 : IF(NBSOUS.EQ.0)THEN 65 : MELEME=IPT1 66 : ELSE 67 : MELEME=IPT1.LISOUS(IE1) 68 : SEGACT,MELEME 69 : ENDIF 70 : ILC=ITYPEL 71 : IF(ILC.NE.14.AND.ILC.NE.16.AND.ILC.NE.23.AND.ILC.NE.25)THEN 72 : WRITE(IOIMP,*)'GENJO3: type d"element incorrect' 73 : SEGDES,MELEME*NOMOD 74 : RETURN 75 : ELSE 76 : NBELEM=ICOLOR(/1) 77 : IF(ILC.EQ.23)THEN 78 : NCOT3=NCOT3+4*NBELEM 79 : ELSEIF(ILC.EQ.14)THEN 80 : NCOT4=NCOT4+6*NBELEM 81 : ELSEIF(ILC.EQ.16)THEN 82 : NCOT3=NCOT3+2*NBELEM 83 : NCOT4=NCOT4+3*NBELEM 84 : ELSEIF(ILC.EQ.25)THEN 85 : NCOT3=NCOT3+4*NBELEM 86 : NCOT4=NCOT4+ NBELEM 87 : ENDIF 88 : ENDIF 89 : SEGDES,MELEME*NOMOD 90 : ENDDO 91 : C 92 : IF(IIMPI.EQ.1790)THEN 93 : WRITE(IOIMP,*)'GENJO3: fin verification' 94 : ENDIF 95 : C 96 : C REMPLISSAGE DU SEGMENT DES COTES 97 : C 98 : SEGACT,IPT1 99 : SEGINI,JO3GEN,JO4GEN 100 : IJOI3=0 101 : IJOI4=0 102 : DO IE1=1,MAX(NBSOUS,1) 103 : IF(NBSOUS.EQ.0)THEN 104 : MELEME=IPT1 105 : ELSE 106 : MELEME=IPT1.LISOUS(IE1) 107 : SEGACT,MELEME 108 : ENDIF 109 : ILC=ITYPEL 110 : NBELEM=ICOLOR(/1) 111 : DO IE2=1,NBELEM 112 : IF(ILC.EQ.23)THEN 112 : CALL GF2323(P3,SZ3,NELM3,FLA3, IJOI3,3, 113 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 114 : ELSEIF(ILC.EQ.14)THEN 114 : CALL GF1424(P4,SZ4,NELM4,FLA4, IJOI4,4, 115 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 116 : ELSEIF(ILC.EQ.16)THEN 116 : CALL GF1623(P3,SZ3,NELM3,FLA3, IJOI3,3, 117 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 117 : CALL GF1624(P4,SZ4,NELM4,FLA4, IJOI4,4, 118 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 119 : ELSEIF(ILC.EQ.25)THEN 119 : CALL GF2523(P3,SZ3,NELM3,FLA3, IJOI3,3, 120 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 120 : CALL GF2524(P4,SZ4,NELM4,FLA4, IJOI4,4, 121 : > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) 122 : ENDIF 123 : ENDDO 124 : ENDDO 125 : C 126 : IF(IIMPI.EQ.1790)THEN 127 : WRITE(IOIMP,*)'GENJO3: fin remplissage' 128 : ENDIF 129 : C 130 : C ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES 131 : C 132 : IF(NCOT3.GT.0)THEN 133 : JG=NCOT3 134 : SEGINI,MLENTI,MLENT1 135 : DO IE1=1,NCOT3 136 : LECT(IE1)=IE1 137 : MLENT1.LECT(IE1)=FLA3(IE1) 138 : ENDDO 138 : CALL GENOR2(MLENT1.LECT,LECT,NCOT3) 139 : IF(IIMPI.EQ.1790)THEN 140 : WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' 141 : ENDIF 142 : IFI=MLENT1.LECT(1) 143 : DO IE1=2,NCOT3 144 : IFF=MLENT1.LECT(IE1) 145 : IF(IFI.EQ.IFF)THEN 146 : JE1=LECT(IE1-1) 147 : IF(FLA3(JE1).NE.0)THEN 148 : DO IE2=IE1,NCOT3 149 : IFFF=MLENT1.LECT(IE2) 150 : IF(IFI.NE.IFFF)GOTO 30 151 : JE2=LECT(IE2) 152 : IF(FLA3(JE2).NE.0)THEN 153 : IF(GENTST(P3(1,JE1),P3(1,JE2),3))THEN 154 : FLA3(JE1)=0 155 : FLA3(JE2)=0 156 : GOTO 30 157 : ENDIF 158 : ENDIF 159 : ENDDO 160 : ENDIF 161 : ENDIF 162 : 30 IFI=IFF 163 : ENDDO 164 : SEGSUP,MLENTI,MLENT1 165 : ENDIF 166 : C 167 : IF(NCOT4.GT.0)THEN 168 : JG=NCOT4 169 : SEGINI,MLENTI,MLENT1 170 : DO IE1=1,NCOT4 171 : LECT(IE1)=IE1 172 : MLENT1.LECT(IE1)=FLA4(IE1) 173 : ENDDO 173 : CALL GENOR2(MLENT1.LECT,LECT,NCOT4) 174 : IF(IIMPI.EQ.1790)THEN 175 : WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' 176 : ENDIF 177 : IFI=MLENT1.LECT(1) 178 : DO IE1=2,NCOT4 179 : IFF=MLENT1.LECT(IE1) 180 : IF(IFI.EQ.IFF)THEN 181 : JE1=LECT(IE1-1) 182 : IF(FLA4(JE1).NE.0)THEN 183 : DO IE2=IE1,NCOT4 184 : IFFF=MLENT1.LECT(IE2) 185 : IF(IFI.NE.IFFF)GOTO 40 186 : JE2=LECT(IE2) 187 : IF(FLA4(JE2).NE.0)THEN 188 : IF(GENTST(P4(1,JE1),P4(1,JE2),4))THEN 189 : FLA4(JE1)=0 190 : FLA4(JE2)=0 191 : GOTO 40 192 : ENDIF 193 : ENDIF 194 : ENDDO 195 : ENDIF 196 : ENDIF 197 : 40 IFI=IFF 198 : ENDDO 199 : SEGSUP,MLENTI,MLENT1 200 : ENDIF 201 : C 202 : IF(IIMPI.EQ.1790)THEN 203 : WRITE(IOIMP,*)'GENJO3: fin elimination des doublons' 204 : ENDIF 205 : C 206 : C CONCATENATION DES LISTES 207 : C 208 : IF (NCOT3.GT.0)THEN 209 : NNCOT3=NCOT3 210 : NCOT3=0 211 : DO IE1=1,NNCOT3 212 : IF(FLA3(IE1).NE.0)NCOT3=NCOT3+1 213 : ENDDO 214 : SEGINI,JO3GE1 215 : JE1=0 216 : DO IE1=1,NNCOT3 217 : IF(FLA3(IE1).NE.0)THEN 218 : JE1=JE1+1 219 : DO IE2=1,IDIM 220 : JO3GE1.P3(IE2,JE1)=P3(IE2,IE1) 221 : ENDDO 222 : JO3GE1.SZ3(JE1)=SZ3(IE1) 223 : JO3GE1.NELM3(JE1)=NELM3(IE1) 224 : JO3GE1.FLA3(JE1)=0 225 : ENDIF 226 : ENDDO 227 : SEGSUP,JO3GEN 228 : JO3GEN=JO3GE1 229 : ENDIF 230 : C 231 : IF (NCOT4.GT.0)THEN 232 : NNCOT4=NCOT4 233 : NCOT4=0 234 : DO IE1=1,NNCOT4 235 : IF(FLA4(IE1).NE.0)NCOT4=NCOT4+1 236 : ENDDO 237 : SEGINI,JO4GE1 238 : JE1=0 239 : DO IE1=1,NNCOT4 240 : IF(FLA4(IE1).NE.0)THEN 241 : JE1=JE1+1 242 : DO IE2=1,4 243 : JO4GE1.P4(IE2,JE1)=P4(IE2,IE1) 244 : ENDDO 245 : JO4GE1.SZ4(JE1)=SZ4(IE1) 246 : JO4GE1.NELM4(JE1)=NELM4(IE1) 247 : JO4GE1.FLA4(JE1)=0 248 : ENDIF 249 : ENDDO 250 : SEGSUP,JO4GEN 251 : JO4GEN=JO4GE1 252 : ENDIF 253 : C 254 : IF(IIMPI.EQ.1790)THEN 255 : WRITE(IOIMP,*)'GENJO3: fin concatenation' 256 : ENDIF 257 : C 258 : C DETERMINATION DES SEGMENTS AVEC VIS-A-VIS 259 : C 260 : IRET=0 261 : IF(NCOT3.GT.1)THEN 262 : JG=NCOT3 263 : SEGINI,MLENTI,MLREEL 264 : DO IE1=1,NCOT3 265 : LECT(IE1)=IE1 266 : DO IE2=1,IDIM 267 : BAR1(IE2)=0.D0 268 : ENDDO 269 : DO IE2=1,3 270 : IPR1=(IDIM+1)*(P3(IE2,IE1)-1) 271 : DO IE3=1,IDIM 272 : BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3) 273 : ENDDO 274 : ENDDO 275 : PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/3 276 : ENDDO 276 : CALL GENOS2(PROG,LECT,NCOT3) 277 : IF(IIMPI.EQ.1790)THEN 278 : WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' 279 : ENDIF 280 : XFI=PROG(1) 281 : DO IE1=2,NCOT3 282 : XFF=PROG(IE1) 283 : IF(ABS(XFI-XFF).LT.XTOL)THEN 284 : JE1=LECT(IE1-1) 285 : IF(FLA3(JE1).EQ.0)THEN 286 : DO IE2=1,IDIM 287 : BAR1(IE2)=0.D0 288 : ENDDO 289 : DO IE2=1,3 290 : IPR1=(IDIM+1)*(P3(IE2,JE1)-1) 291 : DO IE3=1,IDIM 292 : FAC1(IE3,IE2)=XCOOR(IPR1+IE3) 293 : BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2) 294 : ENDDO 295 : ENDDO 296 : DO IE2=IE1,NCOT3 297 : XFFF=PROG(IE2) 298 : IF(ABS(XFI-XFFF).GE.XTOL)GOTO 31 299 : JE2=LECT(IE2) 300 : IF(FLA3(JE2).EQ.0)THEN 301 : DO IE3=1,IDIM 302 : BAR2(IE3)=0.D0 303 : ENDDO 304 : DO IE3=1,3 305 : IPR2=(IDIM+1)*(P3(IE3,JE2)-1) 306 : DO IE4=1,IDIM 307 : FAC2(IE4,IE3)=XCOOR(IPR2+IE4) 308 : BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3) 309 : ENDDO 310 : ENDDO 311 : DIS12=0.D0 312 : DO IE3=1,IDIM 313 : DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2 314 : ENDDO 315 : DIS12=DIS12/9 316 : IF(DIS12.LT.XTOL2)THEN 317 : FLA3(JE1)=JE2 318 : FLA3(JE2)=JE1 318 : CALL GENRD1(FAC1,FAC2,P3(1,JE2),3,XTOL2,IRET) 319 : IF(IRET.NE.0)GOTO 9999 320 : GOTO 31 321 : ENDIF 322 : ENDIF 323 : ENDDO 324 : ENDIF 325 : ENDIF 326 : 31 XFI=XFF 327 : ENDDO 328 : SEGSUP,MLREEL,MLENTI 329 : ENDIF 330 : C 331 : IRET=0 332 : IF(NCOT4.GT.1)THEN 333 : JG=NCOT4 334 : SEGINI,MLENTI,MLREEL 335 : DO IE1=1,NCOT4 336 : LECT(IE1)=IE1 337 : DO IE2=1,IDIM 338 : BAR1(IE2)=0.D0 339 : ENDDO 340 : DO IE2=1,4 341 : IPR1=(IDIM+1)*(P4(IE2,IE1)-1) 342 : DO IE3=1,IDIM 343 : BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3) 344 : ENDDO 345 : ENDDO 346 : PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/4 347 : ENDDO 347 : CALL GENOS2(PROG,LECT,NCOT4) 348 : IF(IIMPI.EQ.1790)THEN 349 : WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' 350 : ENDIF 351 : XFI=PROG(1) 352 : DO IE1=2,NCOT4 353 : XFF=PROG(IE1) 354 : IF(ABS(XFI-XFF).LT.XTOL)THEN 355 : JE1=LECT(IE1-1) 356 : IF(FLA4(JE1).EQ.0)THEN 357 : DO IE2=1,IDIM 358 : BAR1(IE2)=0.D0 359 : ENDDO 360 : DO IE2=1,4 361 : IPR1=(IDIM+1)*(P4(IE2,JE1)-1) 362 : DO IE3=1,IDIM 363 : FAC1(IE3,IE2)=XCOOR(IPR1+IE3) 364 : BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2) 365 : ENDDO 366 : ENDDO 367 : DO IE2=IE1,NCOT4 368 : XFFF=PROG(IE2) 369 : IF(ABS(XFI-XFFF).GE.XTOL)GOTO 41 370 : JE2=LECT(IE2) 371 : IF(FLA4(JE2).EQ.0)THEN 372 : DO IE3=1,IDIM 373 : BAR2(IE3)=0.D0 374 : ENDDO 375 : DO IE3=1,4 376 : IPR2=(IDIM+1)*(P4(IE3,JE2)-1) 377 : DO IE4=1,IDIM 378 : FAC2(IE4,IE3)=XCOOR(IPR2+IE4) 379 : BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3) 380 : ENDDO 381 : ENDDO 382 : DIS12=0.D0 383 : DO IE3=1,IDIM 384 : DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2 385 : ENDDO 386 : DIS12=DIS12/16 387 : IF(DIS12.LT.XTOL2)THEN 388 : FLA4(JE1)=JE2 389 : FLA4(JE2)=JE1 389 : CALL GENRD1(FAC1,FAC2,P4(1,JE2),4,XTOL2,IRET) 390 : IF(IRET.NE.0)GOTO 9999 391 : GOTO 41 392 : ENDIF 393 : ENDIF 394 : ENDDO 395 : ENDIF 396 : ENDIF 397 : 41 XFI=XFF 398 : ENDDO 399 : SEGSUP,MLREEL,MLENTI 400 : ENDIF 401 : C 402 : IF(IIMPI.EQ.1790)THEN 403 : WRITE(IOIMP,*)'GENJO3: fin determination des vis-a-vis' 404 : ENDIF 405 : C 406 : C CREATION DU/DES MAILLAGE(S) DE JOINT 407 : C 408 : NBREF=0 409 : NBSOUS=0 410 : NBELEM=0 411 : DO IE1=1,NCOT3 412 : IF(FLA3(IE1).NE.0)NBELEM=NBELEM+1 413 : ENDDO 414 : NBELEM=NBELEM/2 415 : IF(NBELEM.NE.0)THEN 416 : NBNN=6 417 : SEGINI,MELEME 418 : ITYPEL=18 419 : DO IE1=1,NBELEM 420 : ICOLOR(IE1)=0 421 : ENDDO 422 : IPT3=MELEME 423 : ELSE 424 : IPT3=0 425 : ENDIF 426 : C 427 : NBELEM=0 428 : DO IE1=1,NCOT4 429 : IF(FLA4(IE1).NE.0)NBELEM=NBELEM+1 430 : ENDDO 431 : NBELEM=NBELEM/2 432 : IF(NBELEM.NE.0)THEN 433 : NBNN=8 434 : SEGINI,MELEME 435 : ITYPEL=19 436 : DO IE1=1,NBELEM 437 : ICOLOR(IE1)=0 438 : ENDDO 439 : IPT4=MELEME 440 : ELSE 441 : IPT4=0 442 : ENDIF 443 : C 444 : IF(IPT3*IPT4.EQ.0)THEN 445 : IF(IPT3.EQ.0.AND.IPT4.EQ.0)THEN 446 : WRITE(IOIMP,*)'GENJO3: aucun joint cree' 447 : GOTO 9999 448 : ELSEIF(IPT3.NE.0)THEN 449 : IPT2=IPT3 450 : ELSE 451 : IPT2=IPT4 452 : ENDIF 453 : ELSE 454 : NBSOUS=2 455 : NBNN=0 456 : NBELEM=0 457 : SEGINI,MELEME 458 : LISOUS(1)=IPT3 459 : LISOUS(2)=IPT4 460 : IPT2=MELEME 461 : SEGDES,MELEME 462 : ENDIF 463 : C 464 : IF(IIMPI.EQ.1790)THEN 465 : WRITE(IOIMP,*)'GENJO3: fin creation maillage' 466 : ENDIF 467 : C 468 : C GENERATION DU/DES MAILLAGE(S) DE JOINT 469 : C 470 : IF(IPT3.NE.0)THEN 471 : IELEM=0 472 : DO IE1=1,NCOT3 473 : IF(FLA3(IE1).NE.0)THEN 474 : IELEM=IELEM+1 475 : * 476 : * premier barycentre 477 : * 478 : DO IE2=1,IDIM 479 : BAR1(IE2)=0.D0 480 : ENDDO 481 : IF(SZ3(IE1).EQ.0)THEN 482 : MELEME=IPT1 483 : ELSE 484 : MELEME=IPT1.LISOUS(SZ3(IE1)) 485 : ENDIF 486 : NBNN=NUM(/1) 487 : DO IE3=1,NBNN 488 : IPDUM=(IDIM+1)*(NUM(IE3,NELM3(IE1))-1) 489 : DO IE4=1,IDIM 490 : BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4) 491 : ENDDO 492 : ENDDO 493 : DO IE2=1,IDIM 494 : BAR1(IE2)=BAR1(IE2)/NBNN 495 : ENDDO 496 : * 497 : * Chargement de la premiere face 498 : * 499 : DO IE2=1,3 500 : IPR1=(IDIM+1)*(P3(IE2,IE1)-1) 501 : DO IE3=1,IDIM 502 : FAC1(IE3,IE2)=XCOOR(IPR1+IE3) 503 : ENDDO 504 : ENDDO 505 : * 506 : * second barycentre 507 : * 508 : JE1=FLA3(IE1) 509 : DO IE2=1,IDIM 510 : BAR2(IE2)=0.D0 511 : ENDDO 512 : IF(SZ3(JE1).EQ.0)THEN 513 : MELEME=IPT1 514 : ELSE 515 : MELEME=IPT1.LISOUS(SZ3(JE1)) 516 : ENDIF 517 : NBNN=NUM(/1) 518 : DO IE3=1,NBNN 519 : IPDUM=(IDIM+1)*(NUM(IE3,NELM3(JE1))-1) 520 : DO IE4=1,IDIM 521 : BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4) 522 : ENDDO 523 : ENDDO 524 : DO IE2=1,IDIM 525 : BAR2(IE2)=BAR2(IE2)/NBNN 526 : ENDDO 527 : * 528 : * Chargement de la seconde face 529 : * 530 : DO IE2=1,3 531 : IPR1=(IDIM+1)*(P3(IE2,JE1)-1) 532 : DO IE3=1,IDIM 533 : FAC2(IE3,IE2)=XCOOR(IPR1+IE3) 534 : ENDDO 535 : ENDDO 536 : * 537 : * On ordonne correctement les points 538 : * 538 : CALL GENRD2(FAC1,BAR1,P3(1,IE1),BAR2,P3(1,JE1),3,TOL) 539 : * 540 : * On charge le joint 541 : * 542 : DO IE2=1,3 543 : IPT3.NUM(IE2 ,IELEM)=P3(IE2,IE1) 544 : IPT3.NUM(IE2+3,IELEM)=P3(IE2,JE1) 545 : ENDDO 546 : * 547 : * on efface les 2 cotes 548 : * 549 : FLA3(IE1)=0 550 : FLA3(JE1)=0 551 : ENDIF 552 : ENDDO 553 : SEGDES,IPT3 554 : ENDIF 555 : C 556 : IF(IPT4.NE.0)THEN 557 : IELEM=0 558 : DO IE1=1,NCOT4 559 : IF(FLA4(IE1).NE.0)THEN 560 : IELEM=IELEM+1 561 : * 562 : * premier barycentre 563 : * 564 : DO IE2=1,IDIM 565 : BAR1(IE2)=0.D0 566 : ENDDO 567 : IF(SZ4(IE1).EQ.0)THEN 568 : MELEME=IPT1 569 : ELSE 570 : MELEME=IPT1.LISOUS(SZ4(IE1)) 571 : ENDIF 572 : NBNN=NUM(/1) 573 : DO IE3=1,NBNN 574 : IPDUM=(IDIM+1)*(NUM(IE3,NELM4(IE1))-1) 575 : DO IE4=1,IDIM 576 : BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4) 577 : ENDDO 578 : ENDDO 579 : DO IE2=1,IDIM 580 : BAR1(IE2)=BAR1(IE2)/NBNN 581 : ENDDO 582 : * 583 : * Chargement de la premiere face 584 : * 585 : DO IE2=1,4 586 : IPR1=(IDIM+1)*(P4(IE2,IE1)-1) 587 : DO IE3=1,IDIM 588 : FAC1(IE3,IE2)=XCOOR(IPR1+IE3) 589 : ENDDO 590 : ENDDO 591 : * 592 : * second barycentre 593 : * 594 : JE1=FLA4(IE1) 595 : DO IE2=1,IDIM 596 : BAR2(IE2)=0.D0 597 : ENDDO 598 : IF(SZ4(JE1).EQ.0)THEN 599 : MELEME=IPT1 600 : ELSE 601 : MELEME=IPT1.LISOUS(SZ4(JE1)) 602 : ENDIF 603 : NBNN=NUM(/1) 604 : DO IE3=1,NBNN 605 : IPDUM=(IDIM+1)*(NUM(IE3,NELM4(JE1))-1) 606 : DO IE4=1,IDIM 607 : BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4) 608 : ENDDO 609 : ENDDO 610 : DO IE2=1,IDIM 611 : BAR2(IE2)=BAR2(IE2)/NBNN 612 : ENDDO 613 : * 614 : * Chargement de la seconde face 615 : * 616 : DO IE2=1,4 617 : IPR1=(IDIM+1)*(P4(IE2,JE1)-1) 618 : DO IE3=1,IDIM 619 : FAC2(IE3,IE2)=XCOOR(IPR1+IE3) 620 : ENDDO 621 : ENDDO 622 : * 623 : * On ordonne correctement les points 624 : * 624 : CALL GENRD2(FAC1,BAR1,P4(1,IE1),BAR2,P4(1,JE1),4,TOL) 625 : * 626 : * On charge le joint 627 : * 628 : DO IE2=1,4 629 : IPT4.NUM(IE2 ,IELEM)=P4(IE2,IE1) 630 : IPT4.NUM(IE2+4,IELEM)=P4(IE2,JE1) 631 : ENDDO 632 : * 633 : * on efface les 2 cotes 634 : * 635 : FLA4(IE1)=0 636 : FLA4(JE1)=0 637 : ENDIF 638 : ENDDO 639 : SEGDES,IPT4 640 : ENDIF 641 : C 642 : IF(IIMPI.EQ.1790)THEN 643 : WRITE(IOIMP,*)'GENJO3: fin chargement maillage' 644 : ENDIF 645 : C 646 : C DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE 647 : C 647 : CALL ECROBJ('MAILLAGE',IPT2) 648 : C 649 : 9999 SEGSUP,JO3GEN,JO4GEN 650 : C 651 : NBSOUS=IPT1.LISOUS(/1) 652 : DO IE1=1,MAX(NBSOUS,1) 653 : IF(NBSOUS.EQ.0)THEN 654 : MELEME=IPT1 655 : ELSE 656 : MELEME=IPT1.LISOUS(IE1) 657 : ENDIF 658 : SEGDES,MELEME*NOMOD 659 : ENDDO 660 : C 661 : RETURN 662 : END 663 : 664 : 665 : 666 : 667 :
© Cast3M 2003 - All rights reserved.
Disclaimer