1 : C TQ2CF SOURCE PV 13/04/16 21:15:24 7765 2 : SUBROUTINE TQ2CF(MAIL,MELEMQ,MELEM1,MF1,MELAF, 3 : & MPFD,MFD,MFD2,MFF2,NOMC,IKR) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C************************************************************************* 7 : C Ce SP cree à partir de QCF (MAIL) les connectivités suivantes 8 : C MELEMQ = MAIL ou le QCF correspondant si MAIL non QCF 9 : C Si NOMC=CENTRE on ne calcule que les CENTREs 10 : C 11 : C A : Connectivites elements -> faces (ELTFA) MELAF 12 : C B : Support geometrique des centres (CENTRE) MELEM1 13 : C C : Connectivites faces -> sommets (FACEP) MPFD 14 : C D : Connectivites faces -> elements (FACEL) MFD 15 : C partitionne D': Connectivites faces -> elements (FACEL2) MFD2 16 : C E : Support geometrique des faces (FACE) MF1 17 : C F : Connectivite entre tous les noeuds (MAILFACE) MFF2 18 : C d'une face 19 : C 20 : C IKT = 0 Ce n'était pas des QCF 21 : C IKT = 1 C'était des QCF 22 : C IKL = 0 Ce n'était pas des Lineaires 23 : C IKL = 1 C'était des Lineaires 24 : C IKR = 0 Famille non reconnue 25 : C IKR = 1 C'était des QCF 26 : C IKR = 2 C'était des Lineaires 27 : C IKR = 3 C'était des Macro 28 : C 29 : C************************************************************************* 30 : -INC CCOPTIO 31 : -INC SMCOORD 32 : -INC CCGEOME 33 : -INC SMELEME 34 : POINTEUR MELEM1.MELEME,MF1.MELEME,MELAF.MELEME,MPFD.MELEME 35 : POINTEUR MFD.MELEME,MFD2.MELEME,MFF2.MELEME 36 : -INC SMLENTI 37 : PARAMETER (NBTE=21) 38 : CHARACTER*8 NOM8,LTYPL(NBTE),NOMC 39 : DIMENSION ITC(7),KTA(7,3),JNF(6,7),KNPF(6,7) 40 : DIMENSION INPF(8),INPP(8),INPT(8),INPT2(8),INPT3(8),INPT4(8) 41 : 42 : DATA LTYPL/ 43 : & 'SEG3 ','TRI7 ','QUA9 ', 44 : & 'CU27 ','PR21 ','TE15 ','PY19 ', 45 : & 'SEG2 ','TRI3 ','QUA4 ', 46 : & 'CUB8 ','PRI6 ','TET4 ','PYR5 ', 47 : & 'SEG3 ','TRI6 ','QUA9 ', 48 : & 'CU27 ','PR18 ','TE10 ','PY14 '/ 49 : 50 : DATA ITC/ 2,7,9,27,21,15,19/ 51 : 52 : DATA KTA/ 53 : C nb de faces par type d'élément 54 : & 2, 3, 4, 6, 5, 4, 5, 55 : C numero type elt pour conectivités elt -> face 56 : & 2, 4, 8,16,25,23,9, 57 : C Idc3 58 : & 20,22,25, 0, 6,11,15/ 59 : 60 : DATA INPT/1,0,3,0,0,6,0,10/ 61 : C? DATA INPT2/1,0,2,0,0,4,0,8/ 62 : DATA INPT2/2,0,3,0,0,5,0,9/ 63 : C seg2,seg3,tri4,qua5 64 : C 65 : C nombre de noeuds a prendre en compte pour les faces 66 : DATA INPT3/1,0,3,0,0,7,0,9/ 67 : C type des elements correspondants a des faces 68 : DATA INPT4/1,0,3,0,0,7,0,11/ 69 : C poi1,seg3,tri7,qua9 70 : C 71 : DATA KNPF/ 72 : & 1,1,0,0,0,0, 73 : & 3,3,3,0,0,0, 74 : & 3,3,3,3,0,0, 75 : & 8,8,8,8,8,8, 76 : & 6,6,8,8,8,0, 77 : & 6,6,6,6,0,0, 78 : & 8,6,6,6,6,0/ 79 : 80 : C CORRESPONDANCE 81 : C maillage SEG3 TRI7 QUA9 CU20 PR21 TE15 PY19 82 : C | | | | | | | 83 : C V V V V V V V 84 : C faces SEG2 TRI3 QUA4 PRI6 PYR5 TET4 QUA5 85 : C 86 : C ALIAS seg2 tri3 qua4 pri6 pyr5 tet4 qua5 87 : C ALIAS numero 2 4 8 16 25 23 9 88 : 89 : 90 : DATA JNF/1,3,0,0,0,0, 91 : & 2,4,6,0,0,0, 2,4,6,8,0,0, 92 : & 25,26,21,22,23,24, 19,20,16,17,18,0, 93 : & 12,11,13,14,0,0, 14,15,16,17,18,0/ 94 : 95 : DIMENSION INF(8,29) 96 : C CU20 97 : DATA INF/1,2,3,4,5,6,7,8, 13,14,15,16,17,18,19,20, 98 : & 1,2,3,10,15,14,13,9, 3,4,5,11,17,16,15,10, 99 : & 5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12, 100 : C PR15 101 : & 1,2,3,4,5,6,0,0, 10,11,12,13,14,15,0,0, 102 : & 1,2,3,8 ,12,11,10,7, 3,4,5,9 ,14,13,12,8 , 103 : & 5,6,1,7,10,15,14,9 , 104 : C TE15 105 : & 1,2,3,8,10,7,0,0, 1,2,3,4,5,6,0,0, 3,4,5,9,10,8,0,0, 106 : & 1,6,5,9,10,7,0,0, 107 : C PY15 108 : & 1,2,3,4,5,6,7,8, 1,2,3,10,13,9,0,0, 3,4,5,11,13,10,0,0, 109 : & 5,6,7,12,13,11,0,0, 7,8,1,9,13,12,0,0, 110 : C SEG3 111 : & 1,0,0,0,0,0,0,0, 3,0,0,0,0,0,0,0, 112 : C TRI7 113 : & 1,2,3,0,0,0,0,0, 3,4,5,0,0,0,0,0, 5,6,1,0,0,0,0,0, 114 : C QUA9 115 : & 1,2,3,0,0,0,0,0, 3,4,5,0,0,0,0,0, 5,6,7,0,0,0,0,0, 116 : & 7,8,1,0,0,0,0,0/ 117 : 118 : C**** 119 : C description des faces avec les points centre des surfaces 120 : DIMENSION INF2(9,29) 121 : C CU27 122 : DATA INF2/1,2,3,4,5,6,7,8,25, 13,14,15,16,17,18,19,20,26, 123 : & 1,2,3,10,15,14,13,9,21, 3,4,5,11,17,16,15,10,22, 124 : & 5,6,7,12,19,18,17,11,23, 7,8,1,9,13,20,19,12,24, 125 : C PR21 126 : & 1,2,3,4,5,6,19,0,0, 10,11,12,13,14,15,20,0,0, 127 : & 1,2,3,8 ,12,11,10,7,16, 3,4,5,9 ,14,13,12,8 ,17, 128 : & 5,6,1,7,10,15,14,9 ,18, 129 : C TE15 130 : & 1,2,3,8,10,7,12,0,0, 1,2,3,4,5,6,11,0,0, 131 : & 3,4,5,9,10,8,13,0,0, 1,6,5,9,10,7,14,0,0, 132 : C PY19 133 : & 1,2,3,4,5,6,7,8,14, 1,2,3,10,13,9,15,0,0, 134 : & 3,4,5,11,13,10,16,0,0, 5,6,7,12,13,11,17,0,0, 135 : & 7,8,1,9,13,12,18,0,0, 136 : C SEG3 137 : & 1,0,0,0,0,0,0,0,0, 3,0,0,0,0,0,0,0,0, 138 : C TRI7 139 : & 1,2,3,0,0,0,0,0,0, 3,4,5,0,0,0,0,0,0, 5,6,1,0,0,0,0,0,0, 140 : C QUA9 141 : & 1,2,3,0,0,0,0,0,0, 3,4,5,0,0,0,0,0,0, 5,6,7,0,0,0,0,0,0, 142 : & 7,8,1,0,0,0,0,0,0/ 143 : 144 : C**** 145 : MELEME=MAIL 146 : MELEMQ=MAIL 147 : IKR=0 148 : IPAS=0 149 : 111 CONTINUE 150 : SEGACT MELEME 151 : NBSOUS=LISOUS(/1) 152 : C On regarde à qui on a à faire 153 : C SONT ce des QCF IKT=1 ? 154 : IKKT=1 155 : IKKL=1 156 : IKKM=1 157 : NBELEM=0 158 : NBSOU1=NBSOUS 159 : IF(NBSOU1.EQ.0)NBSOU1=1 160 : DO 1670 L=1,NBSOU1 161 : IPT1=MELEME 162 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 163 : SEGACT IPT1 164 : NOM8=NOMS(IPT1.ITYPEL)//' ' 164 : CALL OPTLI(IP,LTYPL,NOM8,NBTE) 165 : IF(IP.EQ.0.OR.IP.GT.7)IKKT=0 166 : IF(IP.LT.8.OR.IP.GT.14)IKKL=0 167 : IF(IP.LT.15.OR.IP.GT.21)IKKM=0 168 : NBELEM=NBELEM+IPT1.NUM(/2) 169 : SEGDES IPT1 170 : 1670 CONTINUE 171 : 172 : IF(IPAS.EQ.0)THEN 173 : IF(IKKT.NE.0)IKR=1 174 : IF(IKKL.NE.0)IKR=2 175 : IF(IKKM.NE.0)IKR=3 176 : ENDIF 177 : 178 : IF(IKKT.EQ.0.AND.IKKL.EQ.0)RETURN 179 : IF(IKKL.NE.0)THEN 179 : CALL ECROBJ('MAILLAGE',MELEME) 179 : CALL CHANQU 179 : CALL C20227 179 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 180 : MELEMQ=MELEME 181 : IPAS=1 182 : GO TO 111 183 : ELSEIF(IKKM.NE.0)THEN 183 : CALL ECROBJ('MAILLAGE',MELEME) 183 : CALL CQ2L 183 : CALL CHANQU 183 : CALL C20227 183 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 184 : MELEMQ=MELEME 185 : IPAS=1 186 : GO TO 111 187 : ENDIF 188 : C Ce sont des quadratiques 189 : 190 : NBPT=XCOOR(/1)/(IDIM+1) 191 : JG=NBPT 192 : SEGINI MLENTI,MLENT1 193 : 194 : C ****** Création Pts CENTRE 195 : NBELC=NBELEM 196 : NBNN=1 197 : NBSOUS=0 198 : NBREF=0 199 : SEGINI MELEM1 200 : MELEM1.ITYPEL=1 201 : 201 : CALL INITI(INPF,8,0) 202 : 203 : NPTF=0 204 : K0=0 205 : DO 1671 L=1,NBSOU1 206 : IPT1=MELEME 207 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 208 : SEGACT IPT1 209 : NBEL=IPT1.NUM(/2) 210 : NP =IPT1.NUM(/1) 211 : NOM8=NOMS(IPT1.ITYPEL)//' ' 211 : CALL OPTLI(IP,LTYPL,NOM8,7) 212 : NBF=KTA(IP,1) 213 : IC =ITC(IP) 214 : 215 : DO 1672 K=1,NBEL 216 : K0=K0+1 217 : MELEM1.NUM(1,K0)=IPT1.NUM(IC,K) 218 : MELEM1.ICOLOR(K0)=6 219 : DO 1673 I=1,NBF 220 : ITF=LECT(IPT1.NUM(JNF(I,IP),K)) 221 : IF(ITF.NE.0)GO TO 1673 222 : NPTF=NPTF+1 223 : LECT(IPT1.NUM(JNF(I,IP),K))=NPTF 224 : MLENT1.LECT(NPTF)=IPT1.NUM(JNF(I,IP),K) 225 : NPF=KNPF(I,IP) 226 : INPF(NPF)=INPF(NPF)+1 227 : 1673 CONTINUE 228 : 229 : 1672 CONTINUE 230 : SEGDES IPT1 231 : 1671 CONTINUE 231 : call crech1(melem1,1) 232 : SEGDES MELEM1 233 : SEGINI, MLENT2=MLENTI 234 : 235 : IF(NOMC.EQ.'CENTRE')GO TO 1901 236 : 237 : C ****** Création Pts FACE 238 : NBELEM=NPTF 239 : NBNN=1 240 : NBSOUS=0 241 : NBREF=0 242 : SEGINI MF1 243 : MF1.ITYPEL=1 244 : 245 : DO 1674 K=1,NPTF 246 : MF1.NUM(1,K)=MLENT1.LECT(K) 247 : MF1.ICOLOR(K)=4 248 : 1674 CONTINUE 249 : 250 : C ****** Création ELTFA 251 : NBSOUS=NBSOU1 252 : NBREF=0 253 : NBNN=0 254 : NBELEM=0 255 : SEGINI MELAF 256 : 257 : DO 1771 L=1,NBSOU1 258 : IPT1=MELEME 259 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 260 : SEGACT IPT1 261 : NBELEM=IPT1.NUM(/2) 262 : NP =IPT1.NUM(/1) 263 : NOM8=NOMS(IPT1.ITYPEL)//' ' 263 : CALL OPTLI(IP,LTYPL,NOM8,7) 264 : NBNN=KTA(IP,1) 265 : NBSOUS=0 266 : NBREF=0 267 : SEGINI IPT2 268 : IPT2.ITYPEL=KTA(IP,2) 269 : MELAF.LISOUS(L)=IPT2 270 : 271 : 272 : DO 1772 K=1,NBELEM 273 : DO 1773 I=1,NBNN 274 : IPT2.NUM(I,K)=IPT1.NUM(JNF(I,IP),K) 275 : IPT2.ICOLOR(K)=1 276 : MLENT1.LECT(NPTF)=IPT1.NUM(JNF(I,IP),K) 277 : 1773 CONTINUE 278 : 279 : 1772 CONTINUE 280 : SEGDES IPT1,IPT2 281 : 1771 CONTINUE 282 : 283 : IF(NBSOU1.EQ.1)THEN 284 : IPT2=MELAF.LISOUS(1) 285 : SEGSUP MELAF 286 : MELAF=IPT2 287 : ENDIF 288 : SEGDES MELAF 289 : 290 : C ****** Création FACEL 291 : SEGACT MELEME,MELEM1 292 : NBNN=3 293 : NBELEM=NPTF 294 : NBSOUS=0 295 : NBREF=0 296 : SEGINI MFD 297 : MFD.ITYPEL=3 298 : K0=0 299 : DO 1781 L=1,NBSOU1 300 : IPT1=MELEME 301 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 302 : SEGACT IPT1 303 : NBEL=IPT1.NUM(/2) 304 : NOM8=NOMS(IPT1.ITYPEL)//' ' 304 : CALL OPTLI(IP,LTYPL,NOM8,7) 305 : NBF=KTA(IP,1) 306 : 307 : DO 1782 K=1,NBEL 308 : K0=K0+1 309 : DO 1782 I=1,NBF 310 : I2=IPT1.NUM(JNF(I,IP),K) 311 : NF=LECT(I2) 312 : MFD.NUM(2,NF)=I2 313 : MFD.ICOLOR(NF)=2 314 : I3=MFD.NUM(3,NF) 315 : NC=MELEM1.NUM(1,K0) 316 : IF(I3.EQ.0)THEN 317 : MFD.NUM(1,NF)=NC 318 : MFD.NUM(3,NF)=NC 319 : MFD.ICOLOR(NF)=2 320 : ELSE 321 : IF(NC.LT.I3)THEN 322 : MFD.NUM(1,NF)=NC 323 : MFD.ICOLOR(NF)=2 324 : ELSE 325 : MFD.NUM(1,NF)=I3 326 : MFD.NUM(3,NF)=NC 327 : MFD.ICOLOR(NF)=2 328 : ENDIF 329 : ENDIF 330 : 1782 CONTINUE 331 : SEGDES IPT1 332 : 1781 CONTINUE 333 : SEGDES MELEM1,MELEME 334 : 335 : C ******* Mise au propre FACEL dans le cas Navier-Stokes 336 : NBNN=2 337 : NBELEM=NPTF 338 : NBSOUS=0 339 : NBREF=0 340 : SEGINI IPT2 341 : IPT2.ITYPEL=2 342 : 343 : NBNN=3 344 : NBELEM=NPTF 345 : NBSOUS=0 346 : NBREF=0 347 : SEGINI IPT3 348 : IPT3.ITYPEL=3 349 : 350 : I2=0 351 : I3=0 352 : 353 : NBEL=MFD.NUM(/2) 354 : DO 1783 K=1,NBEL 355 : N1=MFD.NUM(1,K) 356 : NC=MFD.NUM(2,K) 357 : N3=MFD.NUM(3,K) 358 : IF(N1.EQ.N3)THEN 359 : I2=I2+1 360 : IPT2.NUM(1,I2)=N1 361 : IPT2.NUM(2,I2)=NC 362 : IPT2.ICOLOR(I2)=3 363 : ELSE 364 : I3=I3+1 365 : IPT3.NUM(1,I3)=N1 366 : IPT3.NUM(2,I3)=NC 367 : IPT3.NUM(3,I3)=N3 368 : IPT3.ICOLOR(I3)=3 369 : ENDIF 370 : 1783 CONTINUE 371 : 372 : NBNN=2 373 : NBELEM=I2 374 : NBSOUS=0 375 : NBREF=0 376 : SEGADJ IPT2 377 : 378 : NBNN=3 379 : NBELEM=I3 380 : NBSOUS=0 381 : NBREF=0 382 : SEGADJ IPT3 383 : 384 : NBNN=0 385 : NBELEM=0 386 : NBSOUS=2 387 : NBREF=0 388 : SEGINI MFD2 389 : MFD2.LISOUS(1)=IPT3 390 : MFD2.LISOUS(2)=IPT2 391 : SEGDES IPT2,IPT3,MFD,MFD2 392 : 393 : C ****** Création FACEP 393 : CALL INITI(INPP,8,0) 394 : NS=0 395 : DO 1780 L=1,8 396 : NBELEM=INPF(L) 397 : INPF(L)=0 398 : IF(NBELEM.EQ.0)GO TO 1780 399 : NS=NS+1 400 : NBNN=(L+1)/2+1 401 : NBSOUS=0 402 : NBREF=0 403 : SEGINI IPT3 404 : INPP(L)=IPT3 405 : IPT3.ITYPEL=INPT2(L) 406 : SEGDES IPT3 407 : 408 : 1780 CONTINUE 409 : 410 : SEGACT MELEME 411 : 412 : DO 1881 L=1,NBSOU1 413 : IPT1=MELEME 414 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 415 : SEGACT IPT1 416 : NBEL=IPT1.NUM(/2) 417 : NOM8=NOMS(IPT1.ITYPEL)//' ' 417 : CALL OPTLI(IP,LTYPL,NOM8,7) 418 : NBF=KTA(IP,1) 419 : IDC3=KTA(IP,3) 420 : DO 1882 K=1,NBEL 421 : DO 1883 I=1,NBF 422 : I2=IPT1.NUM(JNF(I,IP),K) 423 : NF=LECT(I2) 424 : IF(NF.EQ.0)GO TO 1883 425 : LECT(I2)=0 426 : NPF=KNPF(I,IP) 427 : IPT3=INPP(NPF) 428 : SEGACT IPT3*MOD 429 : IPOS=INPF(NPF)+1 430 : INPF(NPF)=IPOS 431 : J3=0 432 : DO 1884 J=1,NPF,2 433 : J3=J3+1 434 : IPT3.NUM(J3,IPOS)=IPT1.NUM(INF(J,I+IDC3),K) 435 : IPT3.ICOLOR(IPOS)=5 436 : 1884 CONTINUE 437 : IPT3.NUM(J3+1,IPOS)=I2 438 : IPT3.ICOLOR(IPOS)=5 439 : 1883 CONTINUE 440 : 1882 CONTINUE 441 : 1881 CONTINUE 442 : 443 : NBSOUS=0 444 : DO 1885 I=1,8 445 : IF(INPP(I).NE.0)NBSOUS=NBSOUS+1 446 : 1885 CONTINUE 447 : 448 : IF(NBSOUS.EQ.1)THEN 449 : MPFD=IPT3 450 : ELSE 451 : NBREF=0 452 : NBELEM=0 453 : NBNN=0 454 : SEGINI MPFD 455 : NS=0 456 : DO 1886 I=1,8 457 : IF(INPP(I).NE.0)THEN 458 : NS=NS+1 459 : MPFD.LISOUS(NS)=INPP(I) 460 : ENDIF 461 : 1886 CONTINUE 462 : ENDIF 463 : 464 : SEGDES MPFD 465 : 466 : C ****** Création MAILFACE 467 : C !!!!! atention on reutilise INPF 467 : CALL INITI(INPP,8,0) 468 : NS=0 469 : DO 1970 L=1,8 470 : NBELEM=INPF(L) 471 : INPF(L)=0 472 : IF(NBELEM.EQ.0)GO TO 1970 473 : NS=NS+1 474 : NBNN=INPT3(L) 475 : NBSOUS=0 476 : NBREF=0 477 : SEGINI IPT3 478 : INPP(L)=IPT3 479 : IPT3.ITYPEL=INPT4(L) 480 : SEGDES IPT3 481 : 482 : 1970 CONTINUE 483 : 484 : SEGACT MELEME 485 : 486 : DO 1981 L=1,NBSOU1 487 : IPT1=MELEME 488 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 489 : SEGACT IPT1 490 : NBEL=IPT1.NUM(/2) 491 : NOM8=NOMS(IPT1.ITYPEL)//' ' 491 : CALL OPTLI(IP,LTYPL,NOM8,7) 492 : NBF=KTA(IP,1) 493 : IDC3=KTA(IP,3) 494 : DO 1982 K=1,NBEL 495 : DO 1983 I=1,NBF 496 : I2=IPT1.NUM(JNF(I,IP),K) 497 : NF=MLENT2.LECT(I2) 498 : IF(NF.EQ.0)GO TO 1983 499 : MLENT2.LECT(I2)=0 500 : NPF=KNPF(I,IP) 501 : IPT3=INPP(NPF) 502 : SEGACT IPT3*MOD 503 : IPOS=INPF(NPF)+1 504 : INPF(NPF)=IPOS 505 : NPPF=INPT3(NPF) 506 : DO 1984 J=1,NPPF 507 : IPT3.NUM(J,IPOS)=IPT1.NUM(INF2(J,I+IDC3),K) 508 : 1984 CONTINUE 509 : IPT3.ICOLOR(IPOS)=5 510 : 1983 CONTINUE 511 : 1982 CONTINUE 512 : 1981 CONTINUE 513 : 514 : NBSOUS=0 515 : DO 1985 I=1,8 516 : IF(INPP(I).NE.0)NBSOUS=NBSOUS+1 517 : 1985 CONTINUE 518 : 519 : IF(NBSOUS.EQ.1)THEN 520 : MFF2=IPT3 521 : ELSE 522 : NBREF=0 523 : NBELEM=0 524 : NBNN=0 525 : SEGINI MFF2 526 : NS=0 527 : DO 1986 I=1,8 528 : IF(INPP(I).NE.0)THEN 529 : NS=NS+1 530 : MFF2.LISOUS(NS)=INPP(I) 531 : ENDIF 532 : 1986 CONTINUE 533 : ENDIF 534 : C write(6,*)' **** voici MAILFACE dans tq2cf *** ' 534 : C call ecmail(mff2) 535 : C write(6,*) '*********************** ' 536 : SEGDES MFF2 537 : C 538 : 1901 CONTINUE 539 : SEGSUP MLENTI,MLENT1,MLENT2 540 : RETURN 541 : 1001 FORMAT(20(1X,I5)) 542 : END 543 : 544 : 545 : 546 : 547 : 548 : 549 : 550 : 551 : 552 : 553 :
© Cast3M 2003 - All rights reserved.
Disclaimer