1 : C CMACRO SOURCE CHAT 05/01/12 22:09:05 5004 2 : SUBROUTINE CMACRO 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************ 6 : C Ce sp transforme des elemnts quadratique d'un type pris 7 : C dans la liste ci-dessous 8 : C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13 9 : C 3 6 10 15 17 24 26 10 : C 11 : C en les éléments correspondant MACRO (iso p2 ou q2) de la liste 12 : C ci-dessous 13 : C 14 : C SEG3 TRI6 QUA9 CU27 PR18 TE10 PY14 15 : C 3 6 11 33 40 24 ?? 16 : C************************************************************************ 17 : -INC SMELEME 18 : -INC SMCOORD 19 : -INC CCOPTIO 20 : -INC SMLENTI 21 : SEGMENT TRAV 22 : INTEGER IFAC4(4,NBFTM) 23 : ENDSEGMENT 24 : SEGMENT TRAV1 25 : INTEGER NUMF4(9,NBFTM) 26 : ENDSEGMENT 27 : SEGMENT SITAB 28 : INTEGER ITAB(NPA,NBATM) 29 : ENDSEGMENT 30 : SEGMENT SITAC 31 : INTEGER ITAC(NBMAX,NNMAX) 32 : ENDSEGMENT 33 : SEGMENT SITAF 34 : INTEGER ITAF(NBFAX,MMMAX) 35 : ENDSEGMENT 36 : SEGMENT TRAV2 37 : INTEGER NUF(6,NBELT) 38 : ENDSEGMENT 39 : SEGMENT CARA 40 : INTEGER KM(6,NBSOU1) 41 : ENDSEGMENT 42 : 43 : DIMENSION IAR(3,35),IFR(4,20) 44 : DATA IAR /1,2,3,3,4,5,5,6,7,7,8,1, 45 : & 1,9,13,3,10,15,5,11,17,7,12,19, 46 : & 13,14,15,15,16,17,17,18,19,19,20,13, 47 : & 1,2,3,3,4,5,5,6,1,1,7,10,3,8,12,5,9,14, 48 : & 10,11,12,12,13,14,14,15,10, 49 : & 1,2,3,3,4,5,5,6,1,1,7,10,3,8,10,5,9,10, 50 : & 1,2,3,3,4,5,5,6,7,7,8,1,1,9,13,3,10,13, 51 : & 5,11,13,7,12,13/ 52 : 53 : DATA IFR /1,6,9,5, 2,7,10,6, 3,8,11,7, 4,5,12,8, 54 : & 1,2,3,4, 9,10,11,12, 55 : & 1,5,7,4, 2,6,8,5, 3,4,9,6, 1,2,3,0, 7,8,9,0, 56 : & 1,2,3,0, 1,5,4,0, 2,6,5,0, 3,6,4,0, 57 : & 1,2,3,4, 1,6,5,0, 2,7,6,0, 3,8,7,0, 4,5,8,0/ 58 : 59 : C Nb de pts par face par type elt 60 : DIMENSION KNPF(6,7) 61 : DATA KNPF/1,1,0,0,0,0, 62 : & 3,3,3,0,0,0, 63 : & 3,3,3,3,0,0, 64 : & 8,8,8,8,8,8, 65 : & 8,8,8,6,6,0, 66 : & 6,6,6,6,0,0, 67 : & 8,6,6,6,6,0/ 68 : 69 : C Nb d'arretes par face par type elt 70 : DIMENSION KNAF(6,7) 71 : DATA KNAF/0,0,0,0,0,0, 72 : & 0,0,0,0,0,0, 73 : & 0,0,0,0,0,0, 74 : & 4,4,4,4,4,4, 75 : & 4,4,4,3,3,0, 76 : & 3,3,3,3,0,0, 77 : & 4,3,3,3,3,0/ 78 : 79 : DIMENSION INF(8,20) 80 : C CU20 81 : DATA INF/1,2,3,10,15,14,13,9, 3,4,5,11,17,16,15,10, 82 : & 5,6,7,12,19,18,17,11, 7,8,1,9,13,20,19,12, 83 : & 1,2,3,4,5,6,7,8, 13,14,15,16,17,18,19,20, 84 : C PR15 85 : & 1,2,3,8 ,12,11,10,7, 3,4,5,9 ,14,13,12,8 , 86 : & 5,6,1,7,10,15,14,9 , 1,2,3,4,5,6,0,0, 87 : & 10,11,12,13,14,15,0,0, 88 : C TE10 89 : & 1,2,3,4,5,6,0,0, 1,2,3,8,10,7,0,0, 3,4,5,9,10,8,0,0, 90 : & 1,6,5,9,10,7,0,0, 91 : C PY15 92 : & 1,2,3,4,5,6,7,8, 1,2,3,10,13,9,0,0, 3,4,5,11,13,10,0,0, 93 : & 5,6,7,12,13,11,0,0, 7,8,1,9,13,12,0,0/ 94 : 95 : 96 : DIMENSION NUA(12),NUMA(4),XA(3,21),KTA(7,9) 97 : DATA KTA/3,6,10,15,17,24,26, 98 : & 3,6,11,33,40,24,00, 99 : C nb de faces 5? 4? 5? 100 : & 2,3,4 ,6 ,3 ,0 ,1 , 101 : C nb d'arretes 102 : & 0,3,4 ,12,9 ,6 ,8, 103 : C Idec 104 : & 0,0,0 ,0 ,12,21,27, 105 : C Idc3 106 : & 0,0,0 ,0 ,6 ,11,15, 107 : C Nbnn 108 : & 3,6,9 ,27,18,15,14, 109 : C NP 110 : & 3,6,8 ,20,15,10,13, 111 : C IDF 112 : & 0,0,0 ,0 ,6 ,11,15/ 113 : 114 : C SEG3 TRI6 QUA8 CU20 PR15 TE10 PY13 115 : C 3 6 10 15 17 24 26 116 : C SEG3 TRI6 QUA9 CU27 PR18 TE10 PY14 117 : C 3 6 11 33 40 24 ?? 118 : 119 : C************************************************************* 120 : 120 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 121 : IF(IRET.EQ.0)RETURN 122 : 123 : SEGACT MELEME 124 : NBSOU1=LISOUS(/1) 125 : IF(NBSOU1.EQ.0)NBSOU1=1 126 : C write(6,*)' SUB CMACRO ' 127 : 128 : C On vérifie qu'il y a quelque chose à faire 129 : 130 : DO 12 L=1,NBSOU1 131 : IPT1=MELEME 132 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 133 : SEGACT IPT1 134 : ITYP=IPT1.ITYPEL 135 : IKR=0 136 : DO 112 I=1,7 137 : IF(ITYP.EQ.KTA(I,2))IKR=I 138 : 112 CONTINUE 139 : IF(IKR.EQ.0)GO TO 212 140 : SEGDES IPT1 141 : 12 CONTINUE 142 : SEGDES MELEME 142 : CALL ECROBJ('MAILLAGE',MELEME) 143 : C write(6,*)'CMACRO il n y a rien a faire ' 144 : 145 : RETURN 146 : 147 : 212 CONTINUE 148 : 149 : SEGINI CARA 150 : 151 : NBELT=0 152 : NBELC=0 153 : DO 11 L=1,NBSOU1 154 : IPT1=MELEME 155 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 156 : SEGACT IPT1 157 : ITYP=IPT1.ITYPEL 158 : IK=0 159 : DO 111 I=1,7 160 : IF(ITYP.EQ.KTA(I,1))IK=I 161 : 111 CONTINUE 162 : 163 : IF(IK.EQ.0)THEN 163 : CALL ERREUR(29) 164 : RETURN 165 : ENDIF 166 : 167 : 168 : NP =IPT1.NUM(/1) 169 : NBELEM=IPT1.NUM(/2) 170 : IF(IK.EQ.3.OR.IK.EQ.4)THEN 171 : NBELC=NBELC+NBELEM 172 : ENDIF 173 : IF(IK.GT.1)THEN 174 : NBELT=NBELT+NBELEM 175 : ENDIF 176 : KM(1,L)=NBELEM 177 : KM(2,L)=IPT1 178 : 179 : KM(3,L)=IK 180 : C nb d'aretes par element 181 : KM(4,L)=KTA(IK,4) 182 : C nb de faces 183 : KM(5,L)=KTA(IK,3) 184 : SEGDES IPT1 185 : 11 CONTINUE 186 : 187 : NBPT=XCOOR(/1)/(IDIM+1) 188 : JG=NBPT 189 : SEGINI MLENTI,MLENT1 190 : 191 : NPA=3 192 : NBATM=5*NBELT+500 193 : SEGINI SITAB 194 : 195 : NBMAX=4+1 196 : NNMAX=3*NBELT+300 197 : NBFAX=4+1 198 : MMMAX=3*NBELT+300 199 : SEGINI SITAF,SITAC 200 : 201 : NBFTM=5*NBELT+500 202 : SEGINI TRAV,TRAV1,TRAV2 203 : 204 : SEGACT MELEME 205 : 206 : NBFT4=0 207 : NBAT=0 208 : NN=0 209 : MM=0 210 : 211 : NK=0 212 : DO 1 L=1,NBSOU1 213 : IK=KM(3,L) 214 : 215 : IPT1=MELEME 216 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 217 : SEGACT IPT1 218 : NBELEM=IPT1.NUM(/2) 219 : NP =IPT1.NUM(/1) 220 : C write(6,*)' ITYP,NBELEM=',ITYP,NBELEM 221 : 222 : IF(IK.NE.4.AND.IK.NE.5.AND.IK.NE.7)GO TO 1 223 : 224 : IDEC=KTA(IK,5) 225 : IDC3=KTA(IK,6) 226 : IDF =KTA(IK,9) 227 : NBA=KTA(IK,4) 228 : NBF=KTA(IK,3) 229 : C write(6,*)' NBA,NBF,NPF=',NBA,NBF 230 : 231 : DO 2 K=1,NBELEM 232 : NK=NK+1 233 : 234 : DO 5 NA=1,NBA 235 : N1=IPT1.NUM(IAR(1,NA+IDEC),K) 236 : N2=IPT1.NUM(IAR(3,NA+IDEC),K) 237 : IF(N1.GT.N2)THEN 238 : NM=N2 239 : N2=N1 240 : N1=NM 241 : ENDIF 242 : NM=IPT1.NUM(IAR(2,NA+IDEC),K) 243 : 244 : IF(LECT(N1).EQ.0)THEN 245 : C le sommet n'a pas encore été touché 246 : NBAT=NBAT+1 247 : IF(NBAT.GT.NBATM)THEN 248 : C write(6,*)' Taille ITAB 2ème dime insuffisante NBATM=',NBATM 249 : NBATM=NBATM+NBELEM 250 : C write(6,*)' NBATM=',nbatm,' NPA=',npa,nbat 251 : SEGADJ SITAB 252 : ENDIF 253 : 254 : NN=NN+1 255 : 256 : IF(NN.GT.NNMAX)THEN 257 : C write(6,*)' Taille ITAC 2eme dime insuffisante NN=',NN 258 : NNMAX=NNMAX+NBELEM 259 : SEGADJ SITAC 260 : ENDIF 261 : 262 : LECT(N1)=NN 263 : ITAC(1,NN)=1 264 : ITAC(1+1,NN)=NBAT 265 : C write(6,*)' NBAT=',nbat,' nn=',nn,' NB=',ITAC(1,NN),nbat 266 : NUA(NA)=NBAT 267 : ITAB(1,NBAT)=N1 268 : ITAB(2,NBAT)=NM 269 : ITAB(3,NBAT)=N2 270 : GO TO 5 271 : ENDIF 272 : 273 : C On cherche si l'arrete existe deja dans la table ITAC 274 : NN1=LECT(N1) 275 : NB=ITAC(1,NN1) 276 : DO 31 II=1,NB 277 : I=ITAC(II+1,NN1) 278 : IF(N2.EQ.ITAB(3,I).AND.NM.EQ.ITAB(2,I))THEN 279 : NUA(NA)=I 280 : GO TO 5 281 : ENDIF 282 : 31 CONTINUE 283 : 284 : IF(NB.LT.(NBMAX-1))THEN 285 : C l'arrete n existe pas dans la table ITAC qui n'est pas pleine 286 : C On peut donc considerer que l'arrete est nouvelle 287 : NBAT=NBAT+1 288 : ITAC(1,NN1)=NB+1 289 : ITAC(NB+2,NN1)=NBAT 290 : C write(6,*)' NBAT=',nbat,' nn1=',nn1,' NB=',ITAC(1,NN1),nbat 291 : NUA(NA)=NBAT 292 : ITAB(1,NBAT)=N1 293 : ITAB(2,NBAT)=NM 294 : ITAB(3,NBAT)=N2 295 : GO TO 5 296 : ENDIF 297 : 298 : C write(6,*)' Taille ITAC 1ere dime insuffisante NB=',NB 299 : NBMAX=NBMAX+2 300 : SEGADJ SITAC 301 : C On fait une recherche parmis toutes les arretes existantes 302 : 303 : DO 3 I=1,NBAT 304 : IF(N2.EQ.ITAB(3,I).AND.NM.EQ.ITAB(2,I))THEN 305 : NUA(NA)=I 306 : GO TO 5 307 : ENDIF 308 : 3 CONTINUE 309 : 310 : NBAT=NBAT+1 311 : ITAC(1,NN1)=NB+1 312 : ITAC(NB+2,NN1)=NBAT 313 : NUA(NA)=NBAT 314 : ITAB(1,NBAT)=N1 315 : ITAB(2,NBAT)=NM 316 : ITAB(3,NBAT)=N2 317 : 318 : 5 CONTINUE 319 : 320 : C write(6,*)' BCL 6 NBF=',nbf 321 : DO 6 NF=1,NBF 322 : C nb de pts par faces 323 : NPF=KNPF(NF,IK) 324 : C write(6,*)' NPF=',npf 325 : IF(NPF.NE.8)GO TO 6 326 : C nb d'arretes par faces 327 : NAF=KNAF(NF,IK) 328 : 329 : DO 61 NFA=1,NAF 330 : NUMA(NFA)=NUA(IFR(NFA,NF+IDF)) 331 : 61 CONTINUE 332 : 332 : CALL ORDOTA(NUMA,NAF) 333 : IF(MLENT1.LECT(NUMA(1)).EQ.0)THEN 334 : C l'arrete n'a pas encore été touché 335 : NBFT4=NBFT4+1 336 : 337 : IF(NBFT4.GT.NBFTM)THEN 338 : C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4 339 : NBFTM=NBFTM+NBELEM 340 : SEGADJ TRAV,TRAV1 341 : ENDIF 342 : 343 : NUMF4(9,NBFT4)=NPF 344 : DO 621 I=1,NPF 345 : NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K) 346 : 621 CONTINUE 347 : MM=MM+1 348 : 349 : IF(MM.GT.MMMAX)THEN 350 : C write(6,*)' Taille ITAF 2eme dime insuffisante MM=',MM 351 : MMMAX=MMMAX+NBELEM 352 : SEGADJ SITAF 353 : ENDIF 354 : 355 : MLENT1.LECT(NUMA(1))=MM 356 : ITAF(1,MM)=1 357 : ITAF(1+1,MM)=NBFT4 358 : C write(6,*)' NBFT4=',nbft4,' mm=',mm,' NB=',ITAF(1,mm) 359 : C write(6,*)' NUF(NF,NK)=',NBFT4,' NF=',nf,'nk=',nk 360 : NUF(NF,NK)=NBFT4 360 : CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF) 361 : GO TO 6 362 : ENDIF 363 : 364 : C On cherche si la face existe déja dans la table ITAF 365 : MM1=MLENT1.LECT(NUMA(1)) 366 : NB=ITAF(1,MM1) 367 : DO 631 II=1,NB 368 : I=ITAF(II+1,MM1) 369 : IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I) 370 : & .AND.NUMA(1).EQ.IFAC4(1,I))THEN 371 : NUF(NF,NK)=I 372 : C write(6,*)' i NUF(NF,NK)=',i,' NF=',nf,'nk=',nk 373 : GO TO 6 374 : ENDIF 375 : 631 CONTINUE 376 : 377 : IF(NB.LT.(NBFAX-1))THEN 378 : C la face n'existe pas dans la table ITAF qui n'est pas pleine 379 : C On peut donc considerer que la face est nouvelle 380 : NBFT4=NBFT4+1 381 : 382 : IF(NBFT4.GT.NBFTM)THEN 383 : C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4 384 : NBFTM=NBFTM+NBELEM 385 : C write(6,*)' NBFTM=',NBFTM,NBELEM 386 : SEGADJ TRAV,TRAV1 387 : ENDIF 388 : 389 : NUMF4(9,NBFT4)=NPF 390 : DO 622 I=1,NPF 391 : NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K) 392 : 622 CONTINUE 393 : ITAF(1,MM1)=NB+1 394 : ITAF(NB+2,MM1)=NBFT4 395 : C write(6,*)' NBFT4=',NBFT4,' mm1=',mm1,' NB=',ITAF(1,mm1) 396 : NUF(NF,NK)=NBFT4 397 : C write(6,*)' 2 NUF(NF,NK)=',nbft4,' NF=',nf,'nk=',nk 397 : CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF) 398 : GO TO 6 399 : ENDIF 400 : 401 : C write(6,*)' Taille ITAF 1ere dime insuffisante NB=',NB 402 : NBFAX=NBFAX+2 403 : SEGADJ SITAF 404 : C On fait une recherche parmis toutes les faces existantes 405 : 406 : 407 : IF(NAF.EQ.4)THEN 408 : DO 7 I=1,NBFT4 409 : IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I) 410 : & .AND.NUMA(1).EQ.IFAC4(1,I))THEN 411 : C write(6,*)' 3 NUF(NF,NK)=',i,' NF=',nf,'nk=',nk 412 : NUF(NF,NK)=I 413 : GO TO 6 414 : ENDIF 415 : 7 CONTINUE 416 : ELSEIF(NAF.EQ.3)THEN 417 : DO 71 I=1,NBFT4 418 : IF( NUMA(2).EQ.IFAC4(2,I).AND.NUMA(3).EQ.IFAC4(3,I))THEN 419 : C write(6,*)' 4 NUF(NF,NK)=',i,' NF=',nf,'nk=',nk 420 : NUF(NF,NK)=I 421 : GO TO 6 422 : ENDIF 423 : 71 CONTINUE 424 : ENDIF 425 : 426 : 427 : 64 CONTINUE 428 : NBFT4=NBFT4+1 429 : 430 : IF(NBFT4.GT.NBFTM)THEN 431 : C write(6,*)' Taille TRAV NBFT4 insuffisante NBFT4=',NBFT4 432 : NBFTM=NBFTM+NBELEM 433 : SEGADJ TRAV,TRAV1 434 : ENDIF 435 : 436 : ITAF(1,MM1)=NB+1 437 : ITAF(NB+2,MM1)=NBFT4 438 : NUMF4(9,NBFT4)=NPF 439 : DO 623 I=1,NPF 440 : NUMF4(I,NBFT4)=IPT1.NUM(INF(I,NF+IDC3),K) 441 : 623 CONTINUE 442 : NUF(NF,NK)=NBFT4 443 : C write(6,*)' 5 NUF(NF,NK)=',NBFT4,' NF=',nf,'nk=',nk 443 : CALL RSETI(IFAC4(1,NBFT4),NUMA,NAF) 444 : 445 : 6 CONTINUE 446 : 2 CONTINUE 447 : 1 CONTINUE 448 : 449 : C write(6,*)' Fin bcl 1 ' 450 : C********************************************************** 451 : 452 : SEGSUP SITAB,SITAC,SITAF,MLENTI,MLENT1,TRAV 453 : 454 : C********************************************************** 455 : 456 : SEGACT MELEME 457 : 458 : NK=0 459 : NC=0 460 : DO 80 L=1,NBSOU1 461 : IK=KM(3,L) 462 : NBF=KTA(IK,3) 463 : 464 : IF(IK.EQ.1.OR.IK.EQ.2.OR.IK.EQ.6)GO TO 80 465 : 466 : IPT1=MELEME 467 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 468 : SEGACT IPT1 469 : 470 : NBELEM=KM(1,L) 471 : NBNN =KTA(IK,7) 472 : NP =KTA(IK,8) 473 : 474 : NBSOUS=0 475 : NBREF=0 476 : SEGINI IPT2 477 : KM(2,L)=IPT2 478 : IPT2.ITYPEL=KTA(IK,2) 479 : C write(6,*)' IPT2=',ipt2, 480 : C & ' L=',l,' nbnn=',nbnn,' nbelem=',nbelem,' IK=',ik 481 : 482 : IF(IK.GE.4)THEN 483 : C CU27 & PR18 & PY14 484 : IDC3=KTA(IK,6) 485 : 486 : DO 83 K=1,NBELEM 487 : NK=NK+1 488 : DO 8 I=1,NP 489 : IPT2.NUM(I,K)=IPT1.NUM(I,K) 490 : 8 CONTINUE 491 : C write(6,*)' 81 ::: nbf=',nbf,' np=',np,nbelc 492 : DO 81 I=1,NBF 493 : IPT2.NUM(I+NP,K)=NBPT+NBELC+NUF(I,NK) 494 : 81 CONTINUE 495 : IF(IK.EQ.4)THEN 496 : NC=NC+1 497 : IPT2.NUM(NBNN,K)=NBPT+NC 498 : ENDIF 499 : 83 CONTINUE 500 : 501 : ELSEIF(IK.EQ.3)THEN 502 : NP=NBNN-1 503 : DO 84 K=1,NBELEM 504 : NC=NC+1 505 : DO 88 I=1,NP 506 : IPT2.NUM(I,K)=IPT1.NUM(I,K) 507 : 88 CONTINUE 508 : IPT2.NUM(9,K)=NBPT+NC 509 : 84 CONTINUE 510 : 511 : ENDIF 512 : 513 : SEGDES IPT1,IPT2 514 : 80 CONTINUE 515 : 516 : C write(6,*)' NUF ' 517 : C DO 783 K=1,NBELC 518 : C write(6,1011)K,(NUF(i,k),i=1,6) 519 : C783 continue 520 : 521 : C do 784 k=1,nbft4 522 : C write(6,1011)K,(NUMF4(i,k),i=1,9) 523 : C784 continue 524 : 525 : C write(6,*)' NBPT=',nbpt 526 : C write(6,*)' NBAT=',nbat 527 : C write(6,*)' NBELT=',NBELT,' NBFT4=',nbft4 528 : C write(6,*)' NBELC=',NBELC 529 : 530 : NBPTS=NBPT+NBELC+NBFT4 531 : IF(NBPTS.GT.NBPT)SEGADJ MCOORD 532 : 533 : C************** On calcule les coordonnées des points *********** 534 : C write(6,*)' NBPT=',nbpt,(NBPT+NBELC) 535 : 536 : 537 : IF(NBFT4.NE.0)THEN 538 : 539 : C write(6,*)' NBFT4=',nbft4,' NBELC=',nbelc 540 : C write(6,*)' NUMF4 =' 541 : DO 23 J=1,NBFT4 542 : 543 : C write(6,1001)' NUMF4 =',j,(numf4(ii,j),ii=1,9) 544 : NPF=NUMF4(9,J) 545 : C write(6,*)' NPF=',npf 546 : DO 21 I=1,NPF 547 : N1=NUMF4(I,J) 548 : DO 21 M=1,IDIM 549 : XA(M,I)=XCOOR((N1-1)*(IDIM+1) +M) 550 : 21 CONTINUE 551 : 551 : CALL FFFACE(XA,NPF) 552 : 553 : N9=NBPT+NBELC+J 554 : C write(6,*)' N9=',n9,(XA(M,NPF+1),m=1,idim) 555 : DO 22 M=1,IDIM 556 : XCOOR((N9-1)*(IDIM+1) +M)=XA(M,NPF+1) 557 : 22 CONTINUE 558 : 23 CONTINUE 559 : ENDIF 560 : 561 : 562 : IF(NBELC.NE.0)THEN 563 : C write(6,*)' On calcule les coordonnées du pt centre ',NBELC 564 : SEGACT MELEME 565 : NC=0 566 : DO 90 L=1,NBSOU1 567 : 568 : IK=KM(3,L) 569 : IF(IK.EQ.1)GO TO 90 570 : IF(IK.NE.3.AND.IK.NE.4)GO TO 90 571 : IPT1=MELEME 572 : IF(NBSOU1.NE.1)IPT1=LISOUS(L) 573 : SEGACT IPT1 574 : 575 : NBELEM=KM(1,L) 576 : NBNN =KTA(IK,7) 577 : NP =KTA(IK,8) 578 : 579 : IPT2=KM(2,L) 580 : 581 : DO 24 K=1,NBELEM 582 : NC=NC+1 582 : CALL INITD(XA(1,21),IDIM,0.D0) 583 : DO 25 I=1,NP 584 : N1=IPT1.NUM(I,K) 585 : DO 25 M=1,IDIM 586 : XA(M,I)=XCOOR((N1-1)*(IDIM+1) +M) 587 : XA(M,21)=XA(M,21)+XA(M,I) 588 : 25 CONTINUE 589 : 590 : N18=NBPT+NC 591 : C write(6,*)' *** NK=',nk,NBELT,L,' N18=',n18 592 : C write(6,1001)(xa(m,21),m=1,3) 593 : DO 26 M=1,IDIM 594 : XCOOR((N18-1)*(IDIM+1) +M)=XA(M,21)/FLOAT(NP) 595 : 26 CONTINUE 596 : 24 CONTINUE 597 : 598 : 90 CONTINUE 599 : 600 : ENDIF 601 : 602 : 603 : C write(6,*)' NBPT=',nbpt 604 : C write(6,*)' NBAT=',nbat 605 : C do 116 l=1,nbat 606 : C write(6,1011)L,(itab(i,l),i=1,3) 607 : C116 continue 608 : 609 : C write(6,*)' LECT ' 610 : C write(6,1001)(lect(ii),ii=1,nbpt) 611 : 612 : C write(6,*)' ITAC NN=',NN 613 : C do 118 l=1,NN 614 : C nb=itac(1,l) 615 : C write(6,1011)L,itac(1,l),(itac(i+1,l),i=1,nb) 616 : C118 continue 617 : 618 : C write(6,*)' NBFT4=',nbft4 619 : 620 : C do 117 l=1,nbft4 621 : C write(6,1011)L,(ifac4(i,l),i=1,4) 622 : C117 continue 623 : 624 : C write(6,*)' MLENT1.LECT ' 625 : C write(6,1001)(mlent1.lect(ii),ii=1,nbpt) 626 : 627 : C write(6,*)' ITAF MM=',MM 628 : C do 119 l=1,MM 629 : C nb=itaf(1,l) 630 : C write(6,1011)L,itaf(1,l),(itaf(i+1,l),i=1,nb) 631 : C119 continue 632 : 633 : SEGSUP TRAV1 634 : IF(NBSOU1.EQ.1)THEN 635 : IPT3=KM(2,1) 636 : ELSE 637 : C write(6,*)' NBSOU1=',nbsou1 638 : NBSOUS=NBSOU1 639 : NBELEM=0 640 : NBNN=0 641 : NBREF=0 642 : SEGINI IPT3 643 : DO 785 L=1,NBSOU1 644 : IPT3.LISOUS(L)=KM(2,L) 645 : C write(6,*)' IPT3 L=',l,KM(2,L) 646 : C ipt2=KM(2,L) 647 : C segact ipt2 648 : C nbelem=ipt2.num(/2) 649 : C write(6,*)' couleur',nbelem 650 : C write(6,1001)(ipt2.icolor(ii),ii=1,nbelem) 651 : 785 CONTINUE 652 : ENDIF 653 : 654 : SEGDES IPT3 655 : 655 : CALL ECROBJ('MAILLAGE',IPT3) 656 : 657 : SEGSUP CARA,TRAV2 658 : 659 : RETURN 660 : 1011 FORMAT('L=',I3,4X,15(1X,I5)) 661 : 1001 FORMAT(20(1X,I5)) 662 : 1002 FORMAT(10(1X,1PE11.4)) 663 : END 664 : 665 :
© Cast3M 2003 - All rights reserved.
Disclaimer