1 : C CONNE1 SOURCE CHAT 11/03/16 21:17:57 6902 2 : SUBROUTINE CONNE1(IPMODL,XLONG,IXLONG,CONSTI,ICLE,JPT1,JPT2,JPT3, 3 : > IPCHCO,IRET) 4 : C_______________________________________________________________________ 5 : C 6 : C CALCUL DES CONNECTIVITES APPELE PAR CONNEC 7 : C 8 : C Entrees: 9 : C ________ 10 : C 11 : C IPMODL Pointeur sur un objet MMODEL 12 : C XLONG Longeur caracteristique 13 : C IXLONG Champ de longeur caracteristique 14 : C CONSTI nom du constituant 15 : C ICLE mode de modification du maillage pour le calcul 16 : C (1=NORM, 3=POIN, 4=DROI, 5=PLAN, 2=TRAN) 17 : C JPT1| 18 : C JPT2| pointeurs eventuels sur des objets de type point 19 : C JPT3| 20 : C 21 : C 22 : C Sorties: 23 : C ________ 24 : C 25 : C IPCHCO Pointeur sur un MCHAML de Connectivite 26 : C de composantes obligatoires ... 27 : C 28 : C 'NLAR': Non local Longueur cARacteristique 29 : C 'PMOD': Pointeur sur un MMODEL contenant 30 : C l'ensemble des IMODEL accessibles 31 : C pour la sous zone 32 : C 'NPNI': Non local Pointeur Numero Imodel de nmod 33 : C 'NPLI': Non local Pointeur LIstenti 34 : C 35 : C ... et eventuellement 36 : C 37 : C 'POT1': Point ou vecteur de construction de symetrie 38 : C (POIN, DROI, PLAN, TRAN) 39 : C 'POT2': Point de construction de symetrie (DROI) 40 : C 'DISP': Distance pour calcul de symetrie PLAN (PLAN) 41 : C 42 : C IRET 1 ou 0 suivant succes ou pas 43 : C 44 : C Appele par: CONNEC 45 : C ----------- 46 : C 47 : C Appel a: 48 : C -------- 49 : C 50 : C LOADPO : lecture d'un point (pointeur --> x(3)) 51 : C NORPLA : calcul de l'eq. canonique d'un plan passant par 3 pts 52 : C ADJUPO : ajout d'un point dans la pile des points (x(3) --> pointeur) 53 : C NORDRO : calcul du vect. dir. norme de la droite passant par 2 pts 54 : C DISYPT : distance a un point 55 : C DISYDR : distance a une droite 56 : C DISYPL : distance a un plan 57 : C TRTRVE : point translate 58 : C TRSYPT : point symetrique par rapport a un point 59 : C TRSYDR : point symetrique par rapport a une droite 60 : C TRSYPL : point symetrique par rapport a un plan 61 : C ELQUOI, DOXE, DTSHAM 62 : C 63 : C AUTEUR P.PEGON 22/10/92 d'apres C. LA BORDERIE d'apres P.PEGON 64 : C_______________________________________________________________________ 65 : C 66 : IMPLICIT INTEGER(I-N) 67 : IMPLICIT REAL*8(A-H,O-Z) 68 : CHARACTER*16 CONSTI 69 : DIMENSION PT1(3),PT2(3),PT3(3) 70 : C 71 : -INC SMMODEL 72 : -INC CCOPTIO 73 : -INC SMELEME 74 : -INC SMCOORD 75 : -INC SMCHAML 76 : -INC SMLENTI 77 : C 78 : SEGMENT,INFO 79 : INTEGER INFELL(JG) 80 : ENDSEGMENT 81 : C 82 : SEGMENT,WRK1 83 : REAL*8 XE(3,NBNN) 84 : ENDSEGMENT 85 : C 86 : SEGMENT,WRK2 87 : REAL*8 XEJ(3,NBNJ) 88 : ENDSEGMENT 89 : C 90 : POINTEUR IPMAIL.MELEME 91 : POINTEUR MLNUEL.MLENTI 92 : POINTEUR MLNIMO.MLENTI 93 : C 94 : CHARACTER*(NCONCH) CONM 95 : PARAMETER ( NINF=3 ) 96 : INTEGER INFOS(NINF) 97 : SEGMENT NOTYPE 98 : CHARACTER*16 TYPE(NBTYPE) 99 : ENDSEGMENT 100 : * 101 : SEGMENT MPTVAL 102 : INTEGER IPOS(NS) ,NSOF(NS) 103 : INTEGER IVAL(NCOSOU) 104 : CHARACTER*16 TYVAL(NCOSOU) 105 : ENDSEGMENT 106 : C 107 : DATA XMULTL/1.5/ 108 : C 109 : C LECTURE DES POINTS 110 : C 110 : CALL LOADPO(JPT1,PT1) 110 : CALL LOADPO(JPT2,PT2) 110 : CALL LOADPO(JPT3,PT3) 111 : C 112 : C CALCUL DE LA NORMALE NORMEE ET DE LA DISTANCE POUR LE CAS 113 : C DU PLAN, ET AJOUT DU POINT A LA PILE 114 : C 115 : IF(ICLE.EQ.5)THEN 115 : CALL NORPLA(PT1,PT2,PT3,PT1,D) 115 : CALL ADJUPO(PT1,JPT1) 116 : ENDIF 117 : C 118 : C CALCUL DU VECTEUR DIRECTEUR NORME DANS LE CAS DE LA DROITE 119 : C ET AJOUT DU POINT A LA PILE 120 : C 121 : IF(ICLE.EQ.4)THEN 121 : CALL NORDRO(PT1,PT2,PT2) 121 : CALL ADJUPO(PT2,JPT2) 122 : ENDIF 123 : C 124 : IRET=1 125 : C 126 : C____________________________________________________________________ 127 : C 128 : C PREPARATIONS DE LA LONGUEUR CARACTERISTIQUE 129 : C____________________________________________________________________ 130 : C 131 : IF(IXLONG.NE.0)THEN 132 : C 133 : INFOS(1)=0 134 : INFOS(2)=0 135 : INFOS(3)=NIFOUR 136 : C 137 : NBROBL=1 138 : NBRFAC=0 139 : SEGINI NOMID 140 : NOMLAR=NOMID 141 : LESOBL(1)='NLAR' 142 : NBTYPE=1 143 : SEGINI NOTYPE 144 : MOTYPE=NOTYPE 145 : TYPE(1)='REAL*8' 146 : ELSE 147 : XLONG2=(XMULTL*XLONG)**2 148 : ENDIF 149 : C 150 : C ACTIVATION DU MODELE 151 : C 152 : MMODEL=IPMODL 153 : SEGACT,MMODEL 154 : NSOUS=KMODEL(/1) 155 : C 156 : C ACTIVATION DES ZONES ELEMENTAIRES DU MAILLAGE 157 : C 158 : DO 1 ISOUS=1,NSOUS 159 : IMODEL=KMODEL(ISOUS) 160 : SEGACT,IMODEL 161 : IPMAIL=IMAMOD 162 : SEGACT,IPMAIL 163 : 1 CONTINUE 164 : C 165 : C CREATION DU MCHELM 166 : C 167 : N1=NSOUS 168 : L1=22 169 : N3=6 170 : SEGINI,MCHELM 171 : IPCHCO=MCHELM 172 : TITCHE='CONNECTIVITE NON LOCAL' 173 : IFOCHE=IFOUR 174 : C____________________________________________________________________ 175 : C 176 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES 177 : C____________________________________________________________________ 178 : C 179 : DO 500 ISOUS=1,NSOUS 180 : IMODEL=KMODEL(ISOUS) 181 : IPMAIL=IMAMOD 182 : CONCHE(ISOUS)=CONSTI 183 : CONM =CONMOD 184 : NBEL =IPMAIL.NUM(/2) 185 : NBNN =IPMAIL.NUM(/1) 186 : C____________________________________________________________________ 187 : C 188 : C INFORMATION SUR L'ELEMENT FINI 189 : C____________________________________________________________________ 190 : C 191 : MELE=IPMAIL.ITYPEL 192 : IF(infmod(/1).lt.7) then 192 : CALL ELQUOI(MELE,0,5,IPINF,IMODEL) 193 : IF (IERR.NE.0) THEN 194 : GOTO 9999 195 : ENDIF 196 : INFO=IPINF 197 : MINTE=INFELL(11) 198 : segsup INFO 199 : ELSE 200 : minte=infmod(7) 201 : ENDIF 202 : C 203 : C COMPLEMENT MCHELM 204 : C 205 : IMACHE(ISOUS)=IPMAIL 206 : C 207 : INFCHE(ISOUS,1)=0 208 : INFCHE(ISOUS,2)=0 209 : INFCHE(ISOUS,3)=NIFOUR 210 : INFCHE(ISOUS,4)=MINTE 211 : INFCHE(ISOUS,5)=0 212 : INFCHE(ISOUS,6)=5 213 : C____________________________________________________________________ 214 : C 215 : C KOMCHA DANS LE CAS DU CHAMP DE LONGUEUR CHARAC 216 : C____________________________________________________________________ 217 : C 218 : IF(IXLONG.NE.0)THEN 218 : CALL KOMCHA(IXLONG,IPMAIL,CONM,NOMLAR,MOTYPE,1,INFOS,3,IVALAR) 219 : IF (IERR.NE.0) THEN 220 : NOMID=NOMLAR 221 : NOTYPE=MOTYPE 222 : SEGSUP,NOMID,NOTYPE 223 : GOTO 9999 224 : ENDIF 225 : ENDIF 226 : C 227 : C____________________________________________________________________ 228 : C 229 : C TAILLE DES MELVAL A ALLOUER ET ALLOCATION 230 : C____________________________________________________________________ 231 : C 232 : C 233 : C CREATION DU MCHAML DE LA SOUS ZONE 234 : C 235 : IF(ICLE.EQ.1)N2=4 236 : IF(ICLE.EQ.2.OR.ICLE.EQ.3)N2=5 237 : IF(ICLE.EQ.4.OR.ICLE.EQ.5)N2=6 238 : SEGINI,MCHAML 239 : ICHAML(ISOUS)=MCHAML 240 : C 241 : C CREATION DU PREMIER MELVAL 242 : C 243 : C 'NLAR' : DONNE LA LONGUEUR CARACTERISTIQUE 244 : C 245 : C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE 246 : C 247 : NOMCHE(1)='NLAR' 248 : TYPCHE(1)='REAL*8' 249 : N2PTEL=0 250 : N2EL=0 251 : C 252 : IF(IXLONG.NE.0)THEN 253 : MPTVAL=IVALAR 254 : MELVAL=IVAL(1) 255 : SEGINI,MELVA1=MELVAL 256 : IELVAL(1)=MELVA1 256 : CALL DTMVAL(IVALAR,2) 257 : ELSE 258 : C 259 : N1PTEL=1 260 : N1EL=1 261 : SEGINI,MELVAL 262 : IELVAL(1)=MELVAL 263 : VELCHE(1,1)=XLONG 264 : C 265 : ENDIF 266 : C 267 : C 268 : C CREATION DU DEUXIEME MELVAL 269 : C 270 : C 'PMOD' : POINTE SUR UN MODELE INDIQUANT LES ZONES GEOMETRIQUE 271 : C 272 : C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE 273 : C 274 : N1PTEL=0 275 : N1EL=0 276 : N2PTEL=1 277 : N2EL=1 278 : NOMCHE(2)='PMOD' 279 : TYPCHE(2)='POINTEURMMODEL ' 280 : SEGINI MELVAL 281 : IELVAL(2)=MELVAL 282 : IELCHE(1,1)=MMODEL 283 : C 284 : C 285 : C 'NPNI' : POINTE SUR UN LISTENTI CONTENANT LE NUMERO DE IMODEL 286 : C ACCESSIBLE POUR CHAQUE ELEMENT 287 : C 'NPLI' : POINTE SUR UN LISTENTI CONTENANT UNE LINKED LISTE 288 : C DES ELEMENTS ACCESSIBLES SUR CHAQUE ZONES 289 : C 290 : C 291 : N1EL=0 292 : N1PTEL=0 293 : N2PTEL=1 294 : N2EL=NBEL 295 : NOMCHE(3)='NPNI' 296 : TYPCHE(3)='POINTEURLISTENTI' 297 : SEGINI,MELVAL 298 : IELVAL(3)=MELVAL 299 : NOMCHE(4)='NPLI' 300 : TYPCHE(4)='POINTEURLISTENTI' 301 : SEGINI,MELVAL 302 : IELVAL(4)=MELVAL 303 : C 304 : C 305 : C 'POT1' : POINTE SUR UN OBJET DE TYPE POINT 306 : C 307 : C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE 308 : C 309 : IF(ICLE.NE.1)THEN 310 : N1PTEL=0 311 : N1EL=0 312 : N2PTEL=1 313 : N2EL=1 314 : NOMCHE(5)='POT1' 315 : TYPCHE(5)='POINTEURPOINT ' 316 : SEGINI MELVAL 317 : IELVAL(5)=MELVAL 318 : IELCHE(1,1)=JPT1 319 : ENDIF 320 : C 321 : C 322 : C 'POT2' : POINTE SUR UN OBJET DE TYPE POINT 323 : C 324 : C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE 325 : C 326 : IF(ICLE.EQ.4)THEN 327 : N1PTEL=0 328 : N1EL=0 329 : N2PTEL=1 330 : N2EL=1 331 : NOMCHE(6)='POT2' 332 : TYPCHE(6)='POINTEURPOINT ' 333 : SEGINI MELVAL 334 : IELVAL(6)=MELVAL 335 : IELCHE(1,1)=JPT2 336 : ENDIF 337 : C 338 : C 'DISP' : DONNE LA DISTANCE AU PLAN 339 : C 340 : C CE MELVAL EST CONSTANT DANS CHAQUE SS_ZONE 341 : C 342 : IF(ICLE.EQ.5)THEN 343 : N2PTEL=0 344 : N2EL=0 345 : N1PTEL=1 346 : N1EL=1 347 : NOMCHE(6)='DISP' 348 : TYPCHE(6)='REAL*8' 349 : SEGINI,MELVAL 350 : IELVAL(6)=MELVAL 351 : VELCHE(1,1)=D 352 : ENDIF 353 : C 354 : C____________________________________________________________________ 355 : C 356 : C BOUCLE SUR LES ELEMENTS DE LA SS ZONE 357 : C____________________________________________________________________ 358 : C 359 : SEGINI,WRK1 360 : DO 499 IB=1,NBEL 361 : C 362 : C ON CHERCHE LA LONGUEUR MAX SUR L'ELEMENT 363 : C 364 : IF(IXLONG.NE.0)THEN 365 : MELVAL=IELVAL(1) 366 : XLONGM=0.D0 367 : NBGLAR=VELCHE(/1) 368 : DO IGAU=1,NBGLAR 369 : XLONGM=MAX(XLONGM,VELCHE(IGAU,MIN(IB,VELCHE(/2)))) 370 : ENDDO 371 : XLONG2=(XMULTL*XLONGM)**2 372 : ENDIF 373 : C 374 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB 375 : C 375 : CALL DOXE(XCOOR,IDIM,NBNN,IPMAIL.NUM,IB,XE) 376 : C 377 : C SI L'ELEMENT EST A PLUS DE XLONG D'UNE SYMETRIE IL 378 : C N'Y A PAS DE CONNECTIVITE POSSIBLE 379 : C 380 : XXL2M=0.D0 380 : IF(ICLE.EQ.3)CALL DISYPT(XE,NBNN,PT1, XXL2M) 380 : IF(ICLE.EQ.4)CALL DISYDR(XE,NBNN,PT1,PT2, XXL2M) 380 : IF(ICLE.EQ.5)CALL DISYPL(XE,NBNN,PT1,D , XXL2M) 381 : IF(XXL2M.GE.XLONG2)THEN 382 : MELVAL=IELVAL(3) 383 : IELCHE(1,IB)=0 384 : MELVAL=IELVAL(4) 385 : IELCHE(1,IB)=0 386 : ELSE 387 : C 388 : C CREATION DU PREMIER LISTENTI 389 : C 390 : JG=0 391 : SEGINI MLNIMO 392 : MELVAL=IELVAL(3) 393 : IELCHE(1,IB)=MLNIMO 394 : C 395 : C CREATION DU DDUXIEME LISTENTI 396 : C 397 : JG=0 398 : SEGINI,MLENTI 399 : MELVAL=IELVAL(4) 400 : IELCHE(1,IB)=MLENTI 401 : C____________________________________________________________________ 402 : C 403 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES 404 : C____________________________________________________________________ 405 : C 406 : DO 450 ISOUSJ=1,NSOUS 407 : IMODE1=KMODEL(ISOUSJ) 408 : IPT1=IMODE1.IMAMOD 409 : NBELEJ=IPT1.NUM(/2) 410 : NBNJ =IPT1.NUM(/1) 411 : * PV faux et non utilisé MINTE =INFCHE(4,ISOUSJ) 412 : C____________________________________________________________________ 413 : C 414 : C BOUCLE SUR LES ELEMENTS DE LA SS ZONE 415 : C____________________________________________________________________ 416 : C 417 : SEGINI,WRK2 418 : JG=0 419 : SEGINI,MLNUEL 420 : DO 449 IBJ=1,NBELEJ 421 : C 422 : C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IBJ(ISOUSJ) 423 : C 423 : CALL DOXE(XCOOR,IDIM,NBNJ,IPT1.NUM,IBJ,XEJ) 424 : C 425 : C ON TRANSFORME CES COORDONNEES EN FONCTION DES SYMETRIE OU DE LA 426 : C TRANSLATION 427 : C 427 : IF(ICLE.EQ.2)CALL TRTRVE(XEJ,NBNJ,PT1 ) 427 : IF(ICLE.EQ.3)CALL TRSYPT(XEJ,NBNJ,PT1 ) 427 : IF(ICLE.EQ.4)CALL TRSYDR(XEJ,NBNJ,PT1,PT2) 427 : IF(ICLE.EQ.5)CALL TRSYPL(XEJ,NBNJ,PT1,D ) 428 : 429 : C 430 : C ON CHERCHE SI UN DES NOEUDS DE XE SE TROUVE A MOINS DE 431 : C XLONG DE L'UN DES NOEUDS DE XEJ 432 : C 433 : DO 4 IE1=1,NBNN 434 : DO 4 IE2=1,NBNJ 435 : XXLON2=0.D0 436 : DO 3 IE3=1,IDIM 437 : XXLON2=XXLON2+(XE(IE3,IE1)-XEJ(IE3,IE2))**2 438 : 3 CONTINUE 439 : IF(XXLON2.LT.XLONG2)GOTO 6 440 : 4 CONTINUE 441 : GOTO 449 442 : C 443 : C SI C'EST VRAI, ON NOTE LE NUMERO DE L'ELEMENT DANS MLNUEL 444 : C 445 : 6 JG=JG+1 446 : SEGADJ,MLNUEL 447 : MLNUEL.LECT(JG)=IBJ 448 : 449 CONTINUE 449 : C 450 : C NOMBRE D'ELEMENTS ACCESSIBLES 451 : C 452 : NELEAC=JG 453 : SEGSUP,WRK2 454 : C 455 : C SI MLNUEL N'EST PAS VIDE, ON INFORME MLNIMO ET MLENTI 456 : C 457 : IF(NELEAC.GT.0)THEN 458 : NSZA=MLNIMO.LECT(/1) 459 : JG=NSZA+1 460 : SEGADJ,MLNIMO 461 : MLNIMO.LECT(JG)=ISOUSJ 462 : JG1=LECT(/1) 463 : JG=JG1+NELEAC+1 464 : SEGADJ,MLENTI 465 : LECT(JG1+1)=NELEAC 466 : DO IELEAC=1,NELEAC 467 : IG1=JG1+1+IELEAC 468 : LECT(IG1)=MLNUEL.LECT(IELEAC) 469 : C print*,'elemnt acc',lect(ig1) 470 : END DO 471 : ENDIF 472 : SEGSUP,MLNUEL 473 : 450 CONTINUE 474 : C 475 : C ON VERIFIE LA PRESENCE DE CONNECTIVITE ET ON MET EVENTUELLEMENT 476 : C LES POINTEURS A ZERO 477 : C 478 : NSZA=MLNIMO.LECT(/1) 479 : IF(NSZA.EQ.0)THEN 480 : SEGSUP,MLNIMO,MLENTI 481 : MELVAL=IELVAL(3) 482 : IELCHE(1,IB)=0 483 : MELVAL=IELVAL(4) 484 : IELCHE(1,IB)=0 485 : ELSE 486 : SEGDES,MLNIMO 487 : SEGDES,MLENTI 488 : ENDIF 489 : ENDIF 490 : C 491 : 499 CONTINUE 492 : SEGSUP,WRK1 493 : C____________________________________________________________________ 494 : C 495 : C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS 496 : C____________________________________________________________________ 497 : C 498 : * INFO=IPINF 499 : * SEGSUP,INFO 500 : MELVAL=IELVAL(1) 501 : SEGDES,MELVAL 502 : MELVAL=IELVAL(2) 503 : SEGDES,MELVAL 504 : MELVAL=IELVAL(3) 505 : SEGDES,MELVAL 506 : MELVAL=IELVAL(4) 507 : SEGDES,MELVAL 508 : SEGDES,MCHAML 509 : 500 CONTINUE 510 : C____________________________________________________________________ 511 : C 512 : C DESACTIVATION DES CHAMPS GLOBAUX 513 : C____________________________________________________________________ 514 : C 515 : SEGDES,MCHELM 516 : C 517 : DO 8 IE1=1,NSOUS 518 : IMODEL=KMODEL(IE1) 519 : IPMAIL=IMAMOD 520 : C PRINT*,IE1,IMODEL,IPMAIL 521 : SEGDES,IMODEL 522 : SEGDES,IPMAIL 523 : 8 CONTINUE 524 : SEGDES,MMODEL 525 : C 526 : IF(IXLONG.NE.0)THEN 527 : NOMID=NOMLAR 528 : NOTYPE=MOTYPE 529 : SEGSUP,NOMID,NOTYPE 530 : ENDIF 531 : C 532 : RETURN 533 : C____________________________________________________________________ 534 : C 535 : C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 536 : C____________________________________________________________________ 537 : C 538 : 9999 CONTINUE 539 : IF(ISOUS.GT.1)THEN 540 : DO 9991 IE1=1,ISOUS 540 : CALL DTSHAM(ICHAML(IE1)) 541 : 9991 CONTINUE 542 : ENDIF 543 : SEGSUP,MCHELM 544 : IPCHCO=0 545 : IRET=0 546 : C 547 : DO 10 IE1=1,NSOUS 548 : IMODEL=KMODEL(IE1) 549 : IPMAIL=IMAMOD 550 : SEGDES,IPMAIL,IMODEL 551 : 10 CONTINUE 552 : SEGDES,MMODEL 553 : RETURN 554 : END 555 : 556 : 557 : 558 : 559 : 560 : 561 : 562 : 563 : 564 : 565 : 566 : 567 :
© Cast3M 2003 - All rights reserved.
Disclaimer