1 : C RAFF SOURCE CHAT 11/03/16 21:30:07 6902 2 : SUBROUTINE RAFF 3 : IMPLICIT REAL*8(A-H,O-Z) 4 : IMPLICIT INTEGER(I-N) 5 : -INC CCOPTIO 6 : -INC SMCOORD 7 : -INC CCGEOME 8 : -INC SMELEME 9 : -INC SMCHPOI 10 : -INC SMMODEL 11 : -INC SMCHAML 12 : C 13 : C-------------------------------- 14 : C B) VARIABLES RELATIVES A LA 2D ! 15 : C-------------------------------- 16 : SEGMENT KARETE(NBNDS,NCOL) 17 : SEGMENT KARET2(NBNDS,NCOL) 18 : SEGMENT KMILIE(NBNDS,NCOL) 19 : SEGMENT KARPOS(NBNDS) 20 : C 21 : C-------------------------------- 22 : C C) VARIABLES RELATIVES A LA 3D ! 23 : C-------------------------------- 24 : SEGMENT IRELA(NBNDS) 25 : SEGMENT JPLANS(JPLA1,JPLA2) 26 : SEGMENT JPLAN2(JPLA1,JPLA2) 27 : SEGMENT JPLAN3(JPLA1,JPLA2) 28 : SEGMENT JPLCOM(JPLA1) 29 : SEGMENT JNOEFA(JNBFA,5) 30 : SEGMENT IWORK2(JNBSOM) 31 : SEGMENT JFARAF(JNBFA,LLLL) 32 : SEGMENT IWORK1(IJKLMN) 33 : C-------------------------- 34 : C A) VARIABLES 'GENERALES' ! 35 : C-------------------------- 36 : SEGMENT ICPR((XCOOR(/1)/(IDIM+1)),2) 37 : SEGMENT LTYPE(NBLIS,2) 38 : SEGMENT LTYPE2(NBLIS2,4) 39 : SEGMENT ICHPO 40 : REAL*8 XR(NBPTCH),YR(NBPTCH),ZR(NBPTCH),DEN(NBPTCH) 41 : ENDSEGMENT 42 : SEGMENT IDENSI 43 : REAL*8 DENSI(NBNDS) 44 : ENDSEGMENT 45 : C 46 : C--------------------------------------------------- 47 : C D) VARIABLES RELATIVES AUX MAILLAGES DE RELATIONS ! 48 : C--------------------------------------------------- 49 : POINTEUR IPT10.MELEME 50 : POINTEUR IPT11.MELEME 51 : POINTEUR IPT12.MELEME 52 : POINTEUR IPT13.MELEME 53 : POINTEUR IPT14.MELEME 54 : POINTEUR IPT15.MELEME 55 : POINTEUR IPT16.MELEME 56 : SEGMENT MAIREL(NBMAIL) 57 : C======================================================================= 58 : C Lecture des donnees utilisateurs 59 : C======================================================================= 60 : C On lit le maillage a raffiner et le champoint de densite a affecter 60 : CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) 61 : IF (IERR.NE.0) RETURN 61 : CALL LIROBJ('CHPOINT',MCHPO1,1,IRETOU) 62 : IF (IERR.NE.0) RETURN 63 : C 64 : C======================================================================= 65 : C Initialisations - Declarations 66 : C======================================================================= 67 : 68 : NBOUCL=0 69 : NPTINI=(XCOOR(/1)/(IDIM+1)) 70 : SEGACT IPT1 71 : 72 : IJKLMN=4 73 : SEGINI IWORK1 74 : IWORK1(1)=4 75 : IWORK1(2)=8 76 : IWORK1(3)=6 77 : IWORK1(4)=10 78 : 79 : C 80 : C======================================================================= 81 : C Tests sur les donnees 82 : C======================================================================= 83 : C On teste pour savoir si le maillage IPT1 (maillage 1) a un type 84 : C d'elements implemante. 85 : NBLIS=MAX(1,IPT1.LISOUS(/1)) 86 : NSURE=0 87 : SEGINI LTYPE 88 : DO 1 INB=1,MAX(1,IPT1.LISOUS(/1)) 89 : IF (IPT1.LISOUS(/1).EQ.0) THEN 90 : IPT2=IPT1 91 : ELSE 92 : IPT2=IPT1.LISOUS(INB) 93 : SEGACT IPT2 94 : ENDIF 95 : NT=IPT2.ITYPEL 96 : IF (NT.EQ.48) NSURE=NSURE+1 97 : LTYPE(INB,1)=INB 98 : LTYPE(INB,2)=NT 99 : IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND. 100 : + (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND. 101 : + (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48)) THEN 102 : WRITE(*,*) 'Erreur, type d element non pris en compte' 103 : RETURN 104 : ENDIF 105 : C IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND. 106 : C + (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND. 107 : C + (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48).AND.(NT.NE.25).AND. 108 : C + (NT.NE.26)) RETURN 109 : IF ((IPT1.LISOUS(/1).EQ.0).AND.(NT.EQ.48)) RETURN 110 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT2 111 : 1 CONTINUE 112 : C 113 : C======================================================================= 114 : C Separation du maillage initial 115 : C======================================================================= 116 : C Si le maillage initial comporte des lisous de type 48, on le separe 117 : C en deux maillages dont un ne sera compose que des lisous de type 48. 118 : C Maillage d'elements de type 48 : IPT6 119 : C Maillage sans elements de type 48 : IPT1 120 : LCONF2=0 121 : IF (NSURE.EQ.0) GOTO 7 122 : LCONF2=1 123 : C------------------------------- 124 : C A) Creation du maillage IPT6 ! 125 : C------------------------------- 126 : C A.1/** Cas ou il n'y a qu'un lisous de type 48 127 : IF (NSURE.EQ.1) THEN 128 : DO 2 K=1,LTYPE(/1) 129 : IF (LTYPE(K,2).EQ.48) IPT6=IPT1.LISOUS(LTYPE(K,1)) 130 : 2 CONTINUE 131 : ENDIF 132 : C 133 : C A.2/** Cas ou il y a plusieurs lisous de type 48 134 : IF (NSURE.GT.1) THEN 135 : NBREF=0 136 : NBSOUS=NSURE 137 : NBNN=0 138 : NBELEM=0 139 : SEGINI IPT6 140 : KLISOU=0 141 : DO 3 K=1,LTYPE(/1) 142 : IF (LTYPE(K,2).EQ.48) THEN 143 : KLISOU=KLISOU+1 144 : IPT6.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1)) 145 : ENDIF 146 : 3 CONTINUE 147 : ENDIF 148 : C 149 : C------------------------------ 150 : C B) Creation du nouveau IPT1 ! 151 : C------------------------------ 152 : NBSOUS=LTYPE(/1)-NSURE 153 : NBREF=0 154 : C 155 : C B.1/** Cas ou il n'y a qu'un lisous de type different de 48 156 : IF (NBSOUS.EQ.1) THEN 157 : DO 4 K=1,LTYPE(/1) 158 : IF (LTYPE(K,2).NE.48) IPT5=IPT1.LISOUS(LTYPE(K,1)) 159 : 4 CONTINUE 160 : ENDIF 161 : C 162 : C B.2/** Cas ou il y a plusieurs lisous de types differents de 48 163 : IF (NBSOUS.GT.1) THEN 164 : NBNN=0 165 : NBELEM=0 166 : SEGINI IPT5 167 : KLISOU=0 168 : DO 5 K=1,LTYPE(/1) 169 : IF (LTYPE(K,2).NE.48) THEN 170 : KLISOU=KLISOU+1 171 : IPT5.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1)) 172 : ENDIF 173 : 5 CONTINUE 174 : ENDIF 175 : 7 CONTINUE 176 : C 177 : C======================================================================= 178 : C Renumerotation locale des noeuds du maillage 179 : C======================================================================= 180 : C ICPR(I,1)=J : Le Ieme noeud global est le Jeme local 181 : C ICPR(I,2)=J : Le Ieme noeud global appartient a J elements 182 : 9 CONTINUE 183 : SEGACT IPT1 184 : NBOUCL=NBOUCL+1 185 : SEGINI ICPR 186 : NBNDS=0 187 : NCOL=0 188 : DO 11 INB=1,MAX(1,IPT1.LISOUS(/1)) 189 : IF (IPT1.LISOUS(/1).EQ.0) THEN 190 : IPT2=IPT1 191 : ELSE 192 : IPT2=IPT1.LISOUS(INB) 193 : SEGACT IPT2 194 : ENDIF 195 : IF (IPT2.ITYPEL.EQ.48) GOTO 11 196 : DO 10 J=1,IPT2.NUM(/2) 197 : DO 10 I=1,IPT2.NUM(/1) 198 : ITMP=IPT2.NUM(I,J) 199 : IF (ICPR(ITMP,1).NE.0) THEN 200 : ICPR(ITMP,2)=ICPR(ITMP,2)+1 201 : NCOL=MAX(NCOL,ICPR(ITMP,2)) 202 : ELSE 203 : NBNDS=NBNDS+1 204 : ICPR(ITMP,1)=NBNDS 205 : ICPR(ITMP,2)=1 206 : NCOL=MAX(NCOL,ICPR(ITMP,2)) 207 : ENDIF 208 : 10 CONTINUE 209 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT2 210 : 11 CONTINUE 211 : IF (IDIM.EQ.2) NCOL=NCOL*2 212 : IF (IDIM.EQ.3) NCOL=NCOL*4 213 : C 214 : C 215 : C 216 : C 217 : C======================================================================= 218 : C Prise en compte des noeuds de relations 219 : C======================================================================= 220 : SEGINI IRELA 221 : IF (LCONF2.EQ.0) GOTO 1200 222 : SEGACT IPT6 223 : DO 1218 LAA=1,IPT6.LISOUS(/1) 224 : IPT2=IPT6.LISOUS(LAA) 225 : SEGACT IPT2 226 : IF (IPT2.ITYPEL.NE.48) GOTO 1218 227 : DO 1220 J=1,IPT2.NUM(/2) 228 : IRELA(ICPR(IPT2.NUM(1,J),1))=1 229 : 1220 CONTINUE 230 : SEGDES IPT2 231 : 1218 CONTINUE 232 : 1200 CONTINUE 233 : C 234 : C======================================================================= 235 : C Prise en compte du champoint de densite 236 : C======================================================================= 237 : C On affecte une densite a chacun des noeuds du maillage. On calcule 238 : C cette densite a partir des densites existantes dans le champoint, a 239 : C l'aide de la fonction RAFDEN. 240 : C Remarque : on ne prend pas en compte les densites qui pourraient 241 : C existees dans le tableau XCOOR. 242 : C 243 : C------------------------------------------ 244 : C A) Recuperation des valeurs du champoint ! 245 : C------------------------------------------ 246 : SEGACT MCHPO1 247 : IF (MCHPO1.IPCHP(/1).NE.1) RETURN 248 : MSOUPO=MCHPO1.IPCHP(1) 249 : SEGACT MSOUPO 250 : IPT3=IGEOC 251 : MPOVA1=IPOVAL 252 : SEGACT IPT3 253 : SEGACT MPOVA1 254 : IF (MPOVA1.VPOCHA(/2).NE.1) RETURN 255 : NBPTCH=IPT3.NUM(/2) 256 : SEGINI ICHPO 257 : DO 13 I=1,NBPTCH 258 : J=IPT3.NUM(1,I) 259 : XR(I)=XCOOR((J-1)*(IDIM+1)+1) 260 : YR(I)=XCOOR((J-1)*(IDIM+1)+2) 261 : IF (IDIM.EQ.3) ZR(I)=XCOOR((J-1)*(IDIM+1)+3) 262 : DEN(I)=MPOVA1.VPOCHA(I,1) 263 : 13 CONTINUE 264 : SEGINI IDENSI 265 : C 266 : C-------------------------------------------------------------- 267 : C B) Affectation d'une densite a chacun des noeuds du maillage ! 268 : C-------------------------------------------------------------- 269 : DO 15 INB=1,MAX(1,IPT1.LISOUS(/1)) 270 : IF (IPT1.LISOUS(/1).EQ.0) THEN 271 : IPT2=IPT1 272 : ELSE 273 : IPT2=IPT1.LISOUS(INB) 274 : SEGACT IPT2 275 : ENDIF 276 : IF (IPT2.ITYPEL.EQ.48) GOTO 15 277 : DO 14 J=1,IPT2.NUM(/2) 278 : DO 14 I=1,IPT2.NUM(/1) 279 : NGLOB=IPT2.NUM(I,J) 280 : NLOC=ICPR(NGLOB,1) 281 : XPT=XCOOR((NGLOB-1)*(IDIM+1)+1) 282 : YPT=XCOOR((NGLOB-1)*(IDIM+1)+2) 283 : ZPT=0 284 : IF (IDIM.EQ.3) ZPT=XCOOR((NGLOB-1)*(IDIM+1)+3) 284 : CALL RAFDEN(ICHPO,XPT,YPT,ZPT,IDIM,DENPT) 285 : DENSI(NLOC)=DENPT 286 : 14 CONTINUE 287 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT2 288 : 15 CONTINUE 289 : C 290 : C======================================================================= 291 : C Remplissage du tableau KARETE 292 : C======================================================================= 293 : C On remplit le tableau KARETE avec les donnees provenant de l'analyse 294 : C du maillage. 295 : C KARETE(i,j)=k : le ieme noeud local forme une arete 296 : C avec le keme noeud local (k>i) 297 : C KARPOS(i)=k : compteur de position (k=nb d'aretes touchant i) 298 : C KARET2(i,j)=k : l'arete i-j appartient a k elements 299 : JPLA1=NBNDS 300 : JPLA2=NCOL 301 : SEGINI KARETE,KARPOS,KARET2 302 : NBARET=0 303 : NCOL=1 304 : DO 18 INB=1,MAX(1,IPT1.LISOUS(/1)) 305 : IF (IPT1.LISOUS(/1).EQ.0) THEN 306 : IPT2=IPT1 307 : ELSE 308 : IPT2=IPT1.LISOUS(INB) 309 : SEGACT IPT2 310 : ENDIF 311 : IF (IPT2.ITYPEL.EQ.48) GOTO 18 312 : ILPL=LPL(IPT2.ITYPEL) 313 : ILPT=LPT(IPT2.ITYPEL) 314 : DO 17 J=1,IPT2.NUM(/2) 315 : DO 17 K=1,ILPL*2-1,2 316 : NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J) 317 : NPTB=IPT2.NUM(KSEGM(ILPT+K),J) 318 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 319 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 320 : NEXIST=0 321 : DO 16 I=1,MAX(1,KARPOS(NMIN)) 322 : IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I 323 : 16 CONTINUE 324 : IF (NEXIST.EQ.0) THEN 325 : KARPOS(NMIN)=KARPOS(NMIN)+1 326 : KARETE(NMIN,KARPOS(NMIN))=NMAX 327 : KARET2(NMIN,KARPOS(NMIN))=1 328 : NBARET=NBARET+1 329 : NCOL=MAX(NCOL,KARPOS(NMIN)) 330 : ENDIF 331 : IF (NEXIST.NE.0) THEN 332 : KARET2(NMIN,NEXIST)=KARET2(NMIN,NEXIST)+1 333 : ENDIF 334 : 17 CONTINUE 335 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT2 336 : 18 CONTINUE 337 : SEGADJ KARETE,KARET2 338 : SEGDES KARETE,KARPOS,KARET2 339 : C 340 : C======================================================================= 341 : C Remplissage des tableaux JPLANS et JNOEFA 342 : C======================================================================= 343 : C On remplit les tableaux de description des faces dans le cas 3D. 344 : C JPLANS(i,j)=k : la jeme face dont le plus petit sommet en 345 : C numerotation locale est le sommet i est la face k 346 : C JNOEFA(i,1-3)=j-k-l : Les 3 plus petits sommets en numerotation 347 : C locale de la face i sont les noeuds j,k et l 348 : C JNOEFA(i,4-5)=j-k : La face identifiee par les 3 sommets precedents 349 : C appartient aux lisous de type j et k 350 : IF (IDIM.NE.3) GOTO 40 351 : C---------------------------------------------------- 352 : C A) Comptage du nombre d'elements total du maillage ! 353 : C---------------------------------------------------- 354 : NELTOT=0 355 : DO 50 INB=1,MAX(1,IPT1.LISOUS(/1)) 356 : IF (IPT1.LISOUS(/1).EQ.0) THEN 357 : IPT2=IPT1 358 : ELSE 359 : IPT2=IPT1.LISOUS(INB) 360 : SEGACT IPT2 361 : ENDIF 362 : NELTOT=NELTOT+IPT2.NUM(/2) 363 : 50 CONTINUE 364 : C 365 : C------------------------------------------------- 366 : C B) Initialisation des tableaux JPLANS et JNOEFA ! 367 : C------------------------------------------------- 368 : JNBFA=NELTOT*6 369 : JMAXPL=0 370 : JNUMFA=0 371 : SEGINI JPLANS,JPLCOM,JNOEFA 372 : C 373 : C----------------------------------------------- 374 : C C) Remplissage des tableaux JPLANS et JNOEFA ! 375 : C----------------------------------------------- 376 : DO 51 INB=1,MAX(1,IPT1.LISOUS(/1)) 377 : IF (IPT1.LISOUS(/1).EQ.0) THEN 378 : IPT2=IPT1 379 : ELSE 380 : IPT2=IPT1.LISOUS(INB) 381 : SEGACT IPT2 382 : ENDIF 383 : IF (IPT2.ITYPEL.EQ.48) GOTO 51 384 : DO 52 KELEM=1,IPT2.NUM(/2) 385 : JTYPEL=IPT2.ITYPEL 386 : JLTEL1=LTEL(1,JTYPEL) 387 : JLTEL2=LTEL(2,JTYPEL) 388 : DO 53 IBB=1,JLTEL1 389 : JLDEL1=LDEL(1,JLTEL2-1+IBB) 390 : JTYFAC=IWORK1(JLDEL1) 391 : JLDEL2=LDEL(2,JLTEL2-1+IBB) 392 : JNBSOM=NBSOM(JTYFAC) 393 : JSPOS=NSPOS(JTYFAC) 394 : SEGINI IWORK2 395 : DO 54 IAA=1,JNBSOM 396 : NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),KELEM) 397 : IWORK2(IAA)=NGLOBA 398 : 54 CONTINUE 399 : C 400 : C---------------------------------------------------- 401 : C D) Tri des sommets de la face par ordre croissant ! 402 : C---------------------------------------------------- 403 : C On va ranger les 3 plus petits sommets de la face (en numerotation 404 : C globale) dans les variables NPTA, NPTB, NPTC. On les classe par ordre 405 : C croissant. 406 : C 407 : C 1/ Classement des 3 sommets par ordre croissant (num globale) 408 : NPTA=(XCOOR(/1)/(IDIM+1))+1 409 : NPTB=NPTA+1 410 : NPTC=NPTB+1 411 : DO 55 ICC=1,JNBSOM 412 : IF (IWORK2(ICC).LT.NPTA) THEN 413 : NPTC=NPTB 414 : NPTB=NPTA 415 : NPTA=IWORK2(ICC) 416 : ELSEIF (IWORK2(ICC).LT.NPTB) THEN 417 : NPTC=NPTB 418 : NPTB=IWORK2(ICC) 419 : ELSEIF (IWORK2(ICC).LT.NPTC) THEN 420 : NPTC=IWORK2(ICC) 421 : ENDIF 422 : 55 CONTINUE 423 : C 424 : C 2/ Classement des 3 sommets par ordre croissant (num locale) 425 : NPTA2=ICPR(NPTA,1) 426 : NPTB2=ICPR(NPTB,1) 427 : NPTC2=ICPR(NPTC,1) 428 : IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN 429 : NPTA=NPTA2 430 : NPTB=MIN(NPTB2,NPTC2) 431 : NPTC=MAX(NPTB2,NPTC2) 432 : ENDIF 433 : IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN 434 : NPTA=NPTB2 435 : NPTB=MIN(NPTA2,NPTC2) 436 : NPTC=MAX(NPTA2,NPTC2) 437 : ENDIF 438 : IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN 439 : NPTA=NPTC2 440 : NPTB=MIN(NPTA2,NPTB2) 441 : NPTC=MAX(NPTA2,NPTB2) 442 : ENDIF 443 : C 444 : C---------------------------------------- 445 : C E) Renseignement des nouvelles faces ! 446 : C---------------------------------------- 447 : SEGACT LTYPE 448 : IHERED=0 449 : DO 1022 MOI=1,IPT2.NUM(/1) 450 : IHERED=IHERED+IRELA(ICPR(IPT2.NUM(MOI,KELEM),1)) 451 : 1022 CONTINUE 452 : IF (JPLCOM(NPTA).EQ.0) THEN 453 : JNUMFA=JNUMFA+1 454 : JPLCOM(NPTA)=JPLCOM(NPTA)+1 455 : JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA 456 : JNOEFA(JNUMFA,1)=NPTA 457 : JNOEFA(JNUMFA,2)=NPTB 458 : JNOEFA(JNUMFA,3)=NPTC 459 : JNOEFA(JNUMFA,4)=LTYPE(INB,2) 460 : IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2) 461 : ELSE 462 : NEXIST=0 463 : DO 56 IDD=1,JPLCOM(NPTA) 464 : ITEMP1=JPLANS(NPTA,IDD) 465 : NAA=JNOEFA(ITEMP1,1) 466 : NBB=JNOEFA(ITEMP1,2) 467 : NCC=JNOEFA(ITEMP1,3) 468 : IF (NAA.EQ.NPTA.AND.NBB.EQ.NPTB.AND.NCC.EQ.NPTC) THEN 469 : NEXIST=ITEMP1 470 : JNOEFA(NEXIST,5)=LTYPE(INB,2) 471 : END IF 472 : 56 CONTINUE 473 : IF (NEXIST.EQ.0) THEN 474 : JNUMFA=JNUMFA+1 475 : JPLCOM(NPTA)=JPLCOM(NPTA)+1 476 : JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA 477 : JNOEFA(JNUMFA,1)=NPTA 478 : JNOEFA(JNUMFA,2)=NPTB 479 : JNOEFA(JNUMFA,3)=NPTC 480 : JNOEFA(JNUMFA,4)=LTYPE(INB,2) 481 : IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2) 482 : ENDIF 483 : ENDIF 484 : JMAXPL=MAX(JMAXPL,JPLCOM(NPTA)) 485 : 53 CONTINUE 486 : 52 CONTINUE 487 : 51 CONTINUE 488 : JPLA2=JMAXPL 489 : JNBFA=JNUMFA 490 : SEGADJ JPLANS,JPLCOM,JNOEFA 491 : SEGDES LTYPE 492 : C 493 : C======================================================================= 494 : C Pre-remplissage du tableau KMILIE 495 : C======================================================================= 496 : C On remplit le tableau lorsqu'il y a des maillages de relations de 497 : C type 48 (IPT6, LCONF2 non nul) 498 : C KARETE(i,j)=k ET KMILIE(i,j)=n : le noeud global n est situe 499 : C au milieu de l'arete [i,k] 500 : 40 CONTINUE 501 : SEGINI KMILIE 502 : SEGACT KARETE*MOD,KARPOS*MOD,KARET2*MOD 503 : IF (LCONF2.EQ.0) THEN 504 : GOTO 28 505 : ENDIF 506 : 22 CONTINUE 507 : NBRELA=0 508 : SEGACT IPT6 509 : DO 218 LAA=1,IPT6.LISOUS(/1) 510 : IPT2=IPT6.LISOUS(LAA) 511 : SEGACT IPT2 512 : IF (IPT2.ITYPEL.NE.48) GOTO 218 513 : IF ((IPT2.ICOLOR(1).NE.1).AND.(IPT2.ICOLOR(1).NE.2)) GOTO 218 514 : DO 220 J=1,IPT2.NUM(/2) 515 : NPTA=IPT2.NUM(2,J) 516 : NPTB=IPT2.NUM(3,J) 517 : NPTC=IPT2.NUM(1,J) 518 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 519 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 520 : NEXIST=0 521 : DO 219 I=1,MAX(1,KARPOS(NMIN)) 522 : IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I 523 : 219 CONTINUE 524 : IF (NEXIST.NE.0) KMILIE(NMIN,NEXIST)=NPTC 525 : IF (NEXIST.NE.0) KARET2(NMIN,NEXIST)=2 526 : C 527 : C----------------------------------------------- 528 : C Prise en compte des relations "hereditaires" ! 529 : C----------------------------------------------- 530 : C Cette partie sert a traiter le cas ou un element serait raffine 531 : C plusieurs fois alors qu'a sa frontiere les autres elements ne le 532 : C seraient pas. Il y aurait donc plusieurs points sur une arete ayant 533 : C des relations de conformite et plus seulement le noeud milieu. 534 : C 535 : C 1/ Test sur la premiere arete : NMIN-NPTC 536 : IF (NEXIST.NE.0) THEN 537 : NEXIS2=0 538 : NMIN2=MIN(NMIN,ICPR(NPTC,1)) 539 : NMAX2=MAX(NMIN,ICPR(NPTC,1)) 540 : DO 24 I=1,MAX(1,KARPOS(NMIN2)) 541 : IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I 542 : 24 CONTINUE 543 : IF (NEXIS2.EQ.0) THEN 544 : NBRELA=NBRELA+1 545 : JNBCOL=KARETE(/2) 546 : JPOSI=KARPOS(NMIN2) 547 : IF (JNBCOL.GT.JPOSI) THEN 548 : KARPOS(NMIN2)=JPOSI+1 549 : KARETE(NMIN2,JPOSI+1)=NMAX2 550 : KARET2(NMIN2,JPOSI+1)=2 551 : ELSEIF (JNBCOL.EQ.JPOSI) THEN 552 : NCOL=JNBCOL+1 553 : SEGADJ KARETE,KMILIE,KARET2 554 : KARETE(NMIN2,JPOSI+1)=NMAX2 555 : KARPOS(NMIN2)=JPOSI+1 556 : KARET2(NMIN2,JPOSI+1)=2 557 : ENDIF 558 : ELSE 559 : KARET2(NMIN2,NEXIS2)=2 560 : ENDIF 561 : C 562 : C 2/ Test sur la deuxieme arete : NMAX-NPTC 563 : NEXIS2=0 564 : NMIN2=MIN(NMAX,ICPR(NPTC,1)) 565 : NMAX2=MAX(NMAX,ICPR(NPTC,1)) 566 : DO 25 I=1,MAX(1,KARPOS(NMIN2)) 567 : IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I 568 : 25 CONTINUE 569 : IF (NEXIS2.EQ.0) THEN 570 : NBRELA=NBRELA+1 571 : JNBCOL=KARETE(/2) 572 : JPOSI=KARPOS(NMIN2) 573 : IF (JNBCOL.GT.JPOSI) THEN 574 : KARPOS(NMIN2)=JPOSI+1 575 : KARETE(NMIN2,JPOSI+1)=NMAX2 576 : KARET2(NMIN2,JPOSI+1)=2 577 : ELSEIF (JNBCOL.EQ.JPOSI) THEN 578 : NCOL=JNBCOL+1 579 : SEGADJ KARETE,KMILIE,KARET2 580 : KARETE(NMIN2,JPOSI+1)=NMAX2 581 : KARPOS(NMIN2)=JPOSI+1 582 : KARET2(NMIN2,JPOSI+1)=2 583 : ENDIF 584 : ELSE 585 : KARET2(NMIN2,NEXIS2)=2 586 : ENDIF 587 : ENDIF 588 : C 589 : 220 CONTINUE 590 : SEGDES IPT2 591 : 218 CONTINUE 592 : IF (NBRELA.NE.0) GOTO 22 593 : 28 CONTINUE 594 : C 595 : C 596 : C======================================================================= 597 : C Pre-remplissage du tableau JFARAF 598 : C======================================================================= 599 : IF (IDIM.NE.3) GOTO 711 600 : JNBFA=JNOEFA(/1) 601 : LLLL=10 602 : SEGINI JFARAF 603 : SEGINI JPLAN2,JPLAN3 604 : IF (LCONF2.EQ.0) GOTO 711 605 : MPOS25=0 606 : JNBSOM=0 607 : 1287 CONTINUE 608 : NBRELA=0 609 : DO 670 MIE=1,IPT6.LISOUS(/1) 610 : IPT2=IPT6.LISOUS(MIE) 611 : SEGACT IPT2 612 : IF (IPT2.ITYPEL.NE.48) GOTO 670 613 : IF ((IPT2.ICOLOR(1).EQ.1).OR.(IPT2.ICOLOR(1).EQ.2)) GOTO 670 614 : LIGNUM=IPT2.NUM(/1) 615 : IF (IPT2.ICOLOR(1).EQ.4) MPOS25=4 616 : IF (IPT2.ICOLOR(1).EQ.5) MPOS25=5 617 : IF (IPT2.ICOLOR(1).EQ.3) JNBSOM=4 618 : IF (IPT2.ICOLOR(1).EQ.4) JNBSOM=3 619 : IF (IPT2.ICOLOR(1).EQ.5) JNBSOM=4 620 : IF (IPT2.ICOLOR(1).EQ.6) JNBSOM=4 621 : SEGINI IWORK2 622 : C 623 : C------------------------- 624 : C A) Recherche de la face ! 625 : C------------------------- 626 : C 1/ Classement des 3 sommets par ordre croissant (num globale) 627 : DO 671,MAA=1,IPT2.NUM(/2) 628 : DO 673 MBB=1,JNBSOM 629 : IWORK2(MBB)=IPT2.NUM(LIGNUM-JNBSOM+MBB,MAA) 630 : 673 CONTINUE 631 : NPTA=(XCOOR(/1)/(IDIM+1))+1 632 : NPTB=NPTA+1 633 : NPTC=NPTB+1 634 : DO 672 ICC=1,JNBSOM 635 : IF (IWORK2(ICC).LT.NPTA) THEN 636 : NPTC=NPTB 637 : NPTB=NPTA 638 : NPTA=IWORK2(ICC) 639 : ELSEIF (IWORK2(ICC).LT.NPTB) THEN 640 : NPTC=NPTB 641 : NPTB=IWORK2(ICC) 642 : ELSEIF (IWORK2(ICC).LT.NPTC) THEN 643 : NPTC=IWORK2(ICC) 644 : ENDIF 645 : 672 CONTINUE 646 : C 647 : C 2/ Classement des 3 sommets par ordre croissant (num locale) 648 : NPTA2=ICPR(NPTA,1) 649 : NPTB2=ICPR(NPTB,1) 650 : NPTC2=ICPR(NPTC,1) 651 : IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN 652 : NPTA=NPTA2 653 : NPTB=MIN(NPTB2,NPTC2) 654 : NPTC=MAX(NPTB2,NPTC2) 655 : ENDIF 656 : IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN 657 : NPTA=NPTB2 658 : NPTB=MIN(NPTA2,NPTC2) 659 : NPTC=MAX(NPTA2,NPTC2) 660 : ENDIF 661 : IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN 662 : NPTA=NPTC2 663 : NPTB=MIN(NPTA2,NPTB2) 664 : NPTC=MAX(NPTA2,NPTB2) 665 : ENDIF 666 : C 667 : C 3/ Recherche du numero de la face 668 : NEXIS2=0 669 : DO 674 IEE=1,JPLCOM(NPTA) 670 : MTMP=JPLANS(NPTA,IEE) 671 : JJ1=JNOEFA(MTMP,1) 672 : JJ2=JNOEFA(MTMP,2) 673 : JJ3=JNOEFA(MTMP,3) 674 : IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN 675 : NEXIS2=IEE 676 : ENDIF 677 : 674 CONTINUE 678 : IF (NEXIS2.EQ.0) THEN 679 : WRITE(*,*) 'Raffinement impossible, le champ de densite presente 680 : + des variations trop brusques' 681 : GOTO 998 682 : ENDIF 683 : JNUMFA=JPLANS(NPTA,NEXIS2) 684 : C 685 : C 4/ Recherche de la position de la face dans JPLANS 686 : NEXIS2=0 687 : DO 675 MAC=1,JPLCOM(NPTA) 688 : IF (JPLANS(NPTA,MAC).EQ.JNUMFA) NEXIS2=MAC 689 : 675 CONTINUE 690 : C 691 : C---------------------------- 692 : C B) Renseignement de JFARAF ! 693 : C---------------------------- 694 : JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1 695 : LTEMPO=(JPLAN3(NPTA,NEXIS2)-1)*2+1 696 : JFARAF(JNUMFA,LTEMPO)=IPT2.NUM(1,MAA) 697 : IF (MPOS25.NE.0) JFARAF(JNUMFA,LTEMPO+1)=IPT2.NUM(MPOS25,MAA) 698 : IF (JNOEFA(JNUMFA,5).EQ.0) JNOEFA(JNUMFA,5)=48 699 : 671 CONTINUE 700 : 670 CONTINUE 701 : C IF (NBRELA.NE.0) GOTO 1287 702 : 711 CONTINUE 703 : C 704 : C======================================================================= 705 : C Calcul du critere et raffinement si necessaire 706 : C======================================================================= 707 : C Pour calculer le critere, on a besoin d'un modele et d'un chamelem 708 : C constant egal a 1. 709 : C 710 : C------------------------------------------ 711 : C A) Creation d'un modele simple : MMODE1 ! 712 : C------------------------------------------ 713 : MN3=0 714 : NFOR=1 715 : NMAT=2 716 : NPARMO=0 717 : NOBMOD=0 718 : N1=1 719 : SEGINI MMODE1 720 : SEGINI IMODE1 721 : MMODE1.KMODEL(1)=IMODE1 722 : IMODE1.FORMOD(1)='MECANIQUE' 723 : IMODE1.MATMOD(1)='ELASTIQUE' 724 : IMODE1.MATMOD(2)='ISOTROPE' 725 : SEGDES IMODE1 726 : C 727 : KARAF2=0 728 : DO 33 INB=1,MAX(1,IPT1.LISOUS(/1)) 729 : IF (IPT1.LISOUS(/1).EQ.0) THEN 730 : IPT2=IPT1 731 : ELSE 732 : IPT2=IPT1.LISOUS(INB) 733 : SEGACT IPT2 734 : ENDIF 735 : SEGACT IMODE1*MOD 736 : IMODE1.IMAMOD=IPT2 737 : IMODE1.NEFMOD=IPT2.ITYPEL 738 : SEGDES IMODE1 739 : C 740 : C------------------------------------------------------- 741 : C B) Creation d'un chamelem constant egal a 1 : MCHEL1 ! 742 : C------------------------------------------------------- 742 : CALL ZEROP(MMODE1,'NOEUD ',MCHEL1) 743 : SEGACT MCHEL1*MOD 744 : MCHEL1.IMACHE(1)=IPT2 745 : IF (IDIM.EQ.2) MCHEL1.IFOCHE=-1 746 : IF (IDIM.EQ.3) MCHEL1.IFOCHE=2 747 : MCHAM1=MCHEL1.ICHAML(1) 748 : SEGACT MCHAM1 749 : MELVA1=MCHAM1.IELVAL(1) 750 : SEGACT MELVA1*MOD 751 : MELVA1.VELCHE(1,1)=1. 752 : SEGDES MELVA1 753 : SEGDES MCHAM1 754 : C 755 : C------------------------------------------------------------- 756 : C C) Calcul de la surface ou du volume des elements : MCHEL2 ! 757 : C------------------------------------------------------------- 757 : CALL INTGCA(MMODE1,MCHEL1,0,1,IRET,XRET,MCHEL2) 758 : SEGACT IPT2 759 : 760 : 761 : C 762 : C--------------------------------------------------------------------- 763 : C D) Creation d'un chamelem indiquant les elements a raffiner MCHAM2 ! 764 : C--------------------------------------------------------------------- 765 : SEGACT KMILIE*MOD 766 : SEGACT MCHEL2 767 : MCHAM2=MCHEL2.ICHAML(1) 768 : SEGACT MCHAM2 769 : MELVA2=MCHAM2.IELVAL(1) 770 : SEGACT MELVA2*MOD 771 : NACREE=0 772 : KARAF=0 773 : DO 32 J=1,IPT2.NUM(/2) 774 : XMOY=0 775 : DO 29 I=1,IPT2.NUM(/1) 776 : NGLOB=IPT2.NUM(I,J) 777 : NLOC=ICPR(NGLOB,1) 778 : DENPT=DENSI(NLOC) 779 : XMOY=XMOY+DENPT/(IPT2.NUM(/1)) 780 : 29 CONTINUE 781 : XINT=MELVA2.VELCHE(1,J) 782 : XDIM=IDIM*1.0 783 : IF ((XMOY-(XINT**(1/XDIM))).LT.0) THEN 784 : MELVA2.VELCHE(1,J)=1 785 : KARAF=KARAF+1 786 : ILPT=LPT(IPT2.ITYPEL) 787 : ILPL=LPL(IPT2.ITYPEL) 788 : DO 31 K=1,ILPL*2-1,2 789 : NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J) 790 : NPTB=IPT2.NUM(KSEGM(ILPT+K),J) 791 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 792 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 793 : NEXIST=0 794 : DO 30 I=1,MAX(1,KARPOS(NMIN)) 795 : IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I 796 : 30 CONTINUE 797 : IF (KMILIE(NMIN,NEXIST).EQ.0) THEN 798 : NACREE=NACREE+1 799 : KMILIE(NMIN,NEXIST)=-1 800 : ENDIF 801 : 31 CONTINUE 802 : C 803 : C------------------------------------------- 804 : C E) Comptage du nombre de faces a raffiner ! 805 : C------------------------------------------- 806 : C 1/ Initialisations 807 : IF (IDIM.NE.3) GOTO 32 808 : JTYPEL=IPT2.ITYPEL 809 : JLTEL1=LTEL(1,JTYPEL) 810 : JLTEL2=LTEL(2,JTYPEL) 811 : DO 73 IBB=1,JLTEL1 812 : JLDEL1=LDEL(1,JLTEL2-1+IBB) 813 : JTYFAC=IWORK1(JLDEL1) 814 : JLDEL2=LDEL(2,JLTEL2-1+IBB) 815 : C JNBPTS=NBNNE(JTYFAC) 816 : JNBSOM=NBSOM(JTYFAC) 817 : JSPOS=NSPOS(JTYFAC) 818 : SEGINI IWORK2 819 : DO 74 IAA=1,JNBSOM 820 : NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),J) 821 : IWORK2(IAA)=NGLOBA 822 : 74 CONTINUE 823 : C 824 : C 2/ Classement des 3 sommets par ordre croissant (num globale) 825 : NPTA=(XCOOR(/1)/(IDIM+1))+1 826 : NPTB=NPTA+1 827 : NPTC=NPTB+1 828 : DO 75 ICC=1,JNBSOM 829 : IF (IWORK2(ICC).LT.NPTA) THEN 830 : NPTC=NPTB 831 : NPTB=NPTA 832 : NPTA=IWORK2(ICC) 833 : ELSEIF (IWORK2(ICC).LT.NPTB) THEN 834 : NPTC=NPTB 835 : NPTB=IWORK2(ICC) 836 : ELSEIF (IWORK2(ICC).LT.NPTC) THEN 837 : NPTC=IWORK2(ICC) 838 : ENDIF 839 : 75 CONTINUE 840 : C 841 : C 3/ Classement des 3 sommets par ordre croissant (num locale) 842 : NPTA2=ICPR(NPTA,1) 843 : NPTB2=ICPR(NPTB,1) 844 : NPTC2=ICPR(NPTC,1) 845 : IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN 846 : NPTA=NPTA2 847 : NPTB=MIN(NPTB2,NPTC2) 848 : NPTC=MAX(NPTB2,NPTC2) 849 : ENDIF 850 : IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN 851 : NPTA=NPTB2 852 : NPTB=MIN(NPTA2,NPTC2) 853 : NPTC=MAX(NPTA2,NPTC2) 854 : ENDIF 855 : IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN 856 : NPTA=NPTC2 857 : NPTB=MIN(NPTA2,NPTB2) 858 : NPTC=MAX(NPTA2,NPTB2) 859 : ENDIF 860 : C 861 : C 4/ Calcul du nombre de points a creer pour raffiner la face 862 : NEXIS2=0 863 : DO 76 IEE=1,JPLCOM(NPTA) 864 : MTMP=JPLANS(NPTA,IEE) 865 : JJ1=JNOEFA(MTMP,1) 866 : JJ2=JNOEFA(MTMP,2) 867 : JJ3=JNOEFA(MTMP,3) 868 : IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN 869 : NEXIS2=IEE 870 : ENDIF 871 : 76 CONTINUE 872 : IF (NEXIS2.NE.0) THEN 873 : KFARAF=JPLAN2(NPTA,NEXIS2) 874 : IF (KFARAF.EQ.0) THEN 875 : NACREE=NACREE+NBINTE(JTYFAC) 876 : JPLAN2(NPTA,NEXIS2)=JPLAN2(NPTA,NEXIS2)+1 877 : ENDIF 878 : ENDIF 879 : 73 CONTINUE 880 : ELSE 881 : MELVA2.VELCHE(1,J)=0 882 : ENDIF 883 : 32 CONTINUE 884 : C 885 : C---------------------------- 886 : C F) Raffinement du maillage ! 887 : C---------------------------- 888 : NML=2 889 : KARAF2=KARAF2+KARAF 890 : IF (KARAF.EQ.0) GOTO 33 891 : C 892 : C 1/ Raffinement d'un maillage 2D 892 : IF (IDIM.EQ.2) CALL RAFF2D(IPT2,ICPR,KARPOS,KARETE,KMILIE, 893 : + MELVA2,NACREE,KARAF,MELEME,IDCP,IPT8,KARET2) 894 : C 895 : C 2/ Raffinement d'un maillage 3D 896 : IF (IDIM.EQ.3) THEN 897 : NML=0 898 : IF ((IPT2.ITYPEL.EQ.25).OR.(IPT2.ITYPEL.EQ.26)) NML=1 899 : ENDIF 900 : C a) Maillage 3D contenant des pyramides 901 : IPT9=0 901 : IF (NML.EQ.1) CALL RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE, 902 : + MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA, 903 : + IPT8,JFARAF,KARET2,IPT9) 904 : C b) Maillage 3D sans pyramides 904 : IF (NML.EQ.0) CALL RAFF3D(IPT2,ICPR,KARPOS,KARETE,KMILIE, 905 : + MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA, 906 : + IPT8,JFARAF,KARET2) 907 : C 908 : C======================================================================= 909 : C Creation du maillage de relations de conformite 910 : C======================================================================= 911 : C-------------------- 912 : C A) Initialisations ! 913 : C-------------------- 914 : IPT10=0 915 : IPT11=0 916 : IPT12=0 917 : IPT13=0 918 : IPT14=0 919 : IPT15=0 920 : IPT16=0 921 : MCONF=0 922 : IF (KARAF2.EQ.0) GOTO 33 923 : IF (IPT8.NE.0) THEN 924 : C 925 : C--------------------------------------- 926 : C B) Traitement des anciennes relations ! 927 : C--------------------------------------- 928 : C 1/ Recherche de l'existence d'anciennes relations a reporter 929 : NB10=0 930 : MLONG=IPT8.NUM(/1) 931 : DO 775 MM=1,IPT8.NUM(/2) 932 : IF (IPT8.NUM(MLONG,MM).EQ.0) NB10=NB10+1 933 : 775 CONTINUE 934 : C 935 : C 2/ Creation de IPT10 936 : IF (NB10.NE.0) THEN 937 : MCOL=0 938 : NBNN=9 939 : NBELEM=NB10 940 : NBREF=0 941 : NBSOUS=0 942 : SEGINI IPT10 943 : IPT10.ITYPEL=48 944 : C 945 : C 3/ Recherche des anciennes relations a reporter 946 : DO 628 MM11=1,IPT8.NUM(/2) 947 : IF (IPT8.NUM(MLONG,MM11).NE.0) GOTO 628 948 : INRELA=IPT8.NUM(1,MM11) 949 : NEXIS6=0 950 : DO 625 KOU=1,IPT6.LISOUS(/1) 951 : IPT2=IPT6.LISOUS(KOU) 952 : SEGACT IPT2 953 : IF (IPT2.ITYPEL.NE.48) GOTO 625 954 : DO 626 JKG=1,IPT2.NUM(/2) 955 : INOEGL=IPT2.NUM(1,JKG) 956 : IF (INOEGL.NE.INRELA) GOTO 626 957 : MCOL=MCOL+1 958 : DO 627 MTMP=1,IPT2.NUM(/1) 959 : IPT8.NUM(MTMP,MM11)=IPT2.NUM(MTMP,JKG) 960 : IPT8.NUM(MLONG,MM11)= IPT2.ICOLOR(JKG) 961 : 627 CONTINUE 962 : GOTO 628 963 : 626 CONTINUE 964 : 625 CONTINUE 965 : 628 CONTINUE 966 : ENDIF 967 : 968 : C 969 : C--------------------------------------- 970 : C C) Traitement des nouvelles relations ! 971 : C--------------------------------------- 972 : C 1/ Recherche de l'existence de nouvelles relations 973 : NB11=0 974 : NB12=0 975 : NB13=0 976 : NB14=0 977 : NB15=0 978 : NB16=0 979 : MLONG=IPT8.NUM(/1) 980 : DO 776 MM=1,IPT8.NUM(/2) 981 : IF (IPT8.NUM(MLONG,MM).EQ.1) NB11=NB11+1 982 : IF (IPT8.NUM(MLONG,MM).EQ.2) NB12=NB12+1 983 : IF (IPT8.NUM(MLONG,MM).EQ.3) NB13=NB13+1 984 : IF (IPT8.NUM(MLONG,MM).EQ.4) NB14=NB14+1 985 : IF (IPT8.NUM(MLONG,MM).EQ.5) NB15=NB15+1 986 : IF (IPT8.NUM(MLONG,MM).EQ.6) NB16=NB16+1 987 : 776 CONTINUE 988 : C 989 : C 2/ Cas des relations 'aretes a 2 noeuds' 990 : IF (NB11.NE.0) THEN 991 : MCONF=MCONF+1 992 : MCOL=0 993 : NBNN=3 994 : NBELEM=NB11 995 : NBREF=0 996 : NBSOUS=0 997 : SEGINI IPT11 998 : IPT11.ITYPEL=48 999 : DO 778 MM11=1,IPT8.NUM(/2) 1000 : IF (IPT8.NUM(MLONG,MM11).NE.1) GOTO 778 1001 : MCOL=MCOL+1 1002 : DO 777 MTMP=1,3 1003 : IPT11.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1004 : IPT11.ICOLOR(MCOL)=1 1005 : 777 CONTINUE 1006 : 778 CONTINUE 1007 : ENDIF 1008 : C 1009 : C 3/ Cas des relations 'aretes a 3 noeuds' 1010 : IF (NB12.NE.0) THEN 1011 : MCONF=MCONF+1 1012 : MCOL=0 1013 : NBNN=4 1014 : NBELEM=NB12 1015 : NBREF=0 1016 : NBSOUS=0 1017 : SEGINI IPT12 1018 : IPT12.ITYPEL=48 1019 : DO 668 MM11=1,IPT8.NUM(/2) 1020 : IF (IPT8.NUM(MLONG,MM11).NE.2) GOTO 668 1021 : MCOL=MCOL+1 1022 : DO 667 MTMP=1,4 1023 : IPT12.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1024 : IPT12.ICOLOR(MCOL)=2 1025 : 667 CONTINUE 1026 : 668 CONTINUE 1027 : ENDIF 1028 : C 1029 : C 4/ Cas des relations 'face QUA4' 1030 : IF (NB13.NE.0) THEN 1031 : MCONF=MCONF+1 1032 : MCOL=0 1033 : NBNN=5 1034 : NBELEM=NB13 1035 : NBREF=0 1036 : NBSOUS=0 1037 : SEGINI IPT13 1038 : IPT13.ITYPEL=48 1039 : DO 658 MM11=1,IPT8.NUM(/2) 1040 : IF (IPT8.NUM(MLONG,MM11).NE.3) GOTO 658 1041 : MCOL=MCOL+1 1042 : DO 657 MTMP=1,5 1043 : IPT13.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1044 : IPT13.ICOLOR(MCOL)=3 1045 : 657 CONTINUE 1046 : 658 CONTINUE 1047 : ENDIF 1048 : C 1049 : C 5/ Cas des relations 'face TRI6' 1050 : IF (NB14.NE.0) THEN 1051 : MCONF=MCONF+1 1052 : MCOL=0 1053 : NBNN=7 1054 : NBELEM=NB14 1055 : NBREF=0 1056 : NBSOUS=0 1057 : SEGINI IPT14 1058 : IPT14.ITYPEL=48 1059 : DO 648 MM11=1,IPT8.NUM(/2) 1060 : IF (IPT8.NUM(MLONG,MM11).NE.4) GOTO 648 1061 : MCOL=MCOL+1 1062 : DO 647 MTMP=1,7 1063 : IPT14.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1064 : IPT14.ICOLOR(MCOL)=4 1065 : 647 CONTINUE 1066 : 648 CONTINUE 1067 : ENDIF 1068 : C 1069 : C 6/ Cas des relations 'face QUA8-1' 1070 : IF (NB15.NE.0) THEN 1071 : MCONF=MCONF+1 1072 : MCOL=0 1073 : NBNN=9 1074 : NBELEM=NB15 1075 : NBREF=0 1076 : NBSOUS=0 1077 : SEGINI IPT15 1078 : IPT15.ITYPEL=48 1079 : DO 638 MM11=1,IPT8.NUM(/2) 1080 : IF (IPT8.NUM(MLONG,MM11).NE.5) GOTO 638 1081 : MCOL=MCOL+1 1082 : DO 637 MTMP=1,9 1083 : IPT15.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1084 : IPT15.ICOLOR(MCOL)=5 1085 : 637 CONTINUE 1086 : 638 CONTINUE 1087 : ENDIF 1088 : C 1089 : C 7/ Cas des relations 'face QUA8-2' 1090 : IF (NB16.NE.0) THEN 1091 : MCONF=MCONF+1 1092 : MCOL=0 1093 : NBNN=9 1094 : NBELEM=NB16 1095 : NBREF=0 1096 : NBSOUS=0 1097 : SEGINI IPT16 1098 : IPT16.ITYPEL=48 1099 : DO 678 MM11=1,IPT8.NUM(/2) 1100 : IF (IPT8.NUM(MLONG,MM11).NE.6) GOTO 678 1101 : MCOL=MCOL+1 1102 : DO 677 MTMP=1,9 1103 : IPT16.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11) 1104 : IPT16.ICOLOR(MCOL)=6 1105 : 677 CONTINUE 1106 : 678 CONTINUE 1107 : ENDIF 1108 : C 1109 : ENDIF 1110 : C 1111 : C-------------------------------------- 1112 : C D) Creation du maillage de relations ! 1113 : C-------------------------------------- 1114 : C 1/ Initialisation de MAIREL 1115 : NBMAIL=6 1116 : SEGINI MAIREL 1117 : MAIREL(1)=IPT11 1118 : MAIREL(2)=IPT12 1119 : MAIREL(3)=IPT13 1120 : MAIREL(4)=IPT14 1121 : MAIREL(5)=IPT15 1122 : MAIREL(6)=IPT16 1123 : C 1124 : C 2/ Initialisation de LTYPE2 1125 : NBLIS2=MCONF+MAX(1,MELEME.LISOUS(/1)) 1126 : SEGINI LTYPE2 1127 : C 1128 : C 3/ Renseignement des lisous non 48 dans LTYPE2 1129 : DO 685 IZZ=1,MAX(1,MELEME.LISOUS(/1)) 1130 : IF (MELEME.LISOUS(/1).EQ.0) THEN 1131 : IPT2=MELEME 1132 : ELSE 1133 : IPT2=MELEME.LISOUS(IZZ) 1134 : SEGACT IPT2 1135 : ENDIF 1136 : LTYPE2(IZZ,1)=IZZ 1137 : LTYPE2(IZZ,2)=IPT2.ITYPEL 1138 : LTYPE2(IZZ,3)=IPT2 1139 : LTYPE2(IZZ,4)=0 1140 : 685 CONTINUE 1141 : C 1142 : C 4/ Renseignement des lisous 48 dans LTYPE2 1143 : IZZ=NBLIS2-MCONF 1144 : DO 686 IXX=1,6 1145 : IF (MAIREL(IXX).EQ.0) GOTO 686 1146 : IPT2=MAIREL(IXX) 1147 : IZZ=IZZ+1 1148 : LTYPE2(IZZ,1)=IZZ 1149 : LTYPE2(IZZ,2)=IPT2.ITYPEL 1150 : LTYPE2(IZZ,3)=IPT2 1151 : LTYPE2(IZZ,4)=IPT2.ICOLOR(1) 1152 : 686 CONTINUE 1153 : C 1154 : C 5/ Creation et renseignement de IPT6 1155 : IF (MCONF.NE.0) THEN 1156 : LCONF2=1 1157 : NBNN=0 1158 : NBELEM=0 1159 : NBREF=0 1160 : NBSOUS=LTYPE2(/1) 1161 : SEGINI IPT6 1162 : DO 613 IRR=1,LTYPE2(/1) 1163 : IPT2=LTYPE2(IRR,3) 1164 : SEGACT IPT2 1165 : IPT6.LISOUS(IRR)=IPT2 1166 : 613 CONTINUE 1167 : ELSE 1168 : LCONF2=0 1169 : IPT6=MELEME 1170 : ENDIF 1171 : C 1172 : C======================================================================= 1173 : C Test sur la progression du raffinement 1174 : C======================================================================= 1175 : C 1176 : IF (IPT1.LISOUS(/1).NE.0) SEGDES IPT2 1177 : C 1178 : SEGDES IPT1,MCHPO1,MSOUPO,MPOVA1,IPT3,KMILIE 1179 : SEGSUP IPT9 1180 : SEGSUP ICPR,KARETE,KARPOS,KARET2,ICHPO,IDENSI 1181 : SEGSUP MCHAM1,MELVA1,MCHAM2,MELVA2,IMODE1 1182 : SEGSUP MMODE1,MCHEL1,MCHEL2 1183 : IF (IDIM.EQ.3) SEGSUP JPLANS,JPLAN2,JPLAN3,JPLCOM,JNOEFA,IWORK2, 1184 : +JFARAF 1185 : C 1186 : IF (KARAF2.NE.0) THEN 1187 : IPT1=MELEME 1188 : GOTO 9 1189 : ENDIF 1190 : C 1191 : 33 CONTINUE 1192 : C 1193 : C ### SORTIE TEMPORAIRE DU PROGRAMME ### 1194 : IF ((KARAF2.EQ.0).AND.(NBOUCL.EQ.1)) THEN 1195 : WRITE(*,*) 'il n est pas necessaire de raffiner le maillage' 1196 : MELEME=IPT1 1197 : GOTO 998 1198 : ENDIF 1199 : C 1200 : IF (MCONF.NE.0) MELEME=IPT6 1201 : C GOTO 998 1202 : C 1203 : C======================================================================= 1204 : C Mises a jour diverses 1205 : C======================================================================= 1206 : C ** On affecte une densite a chaque noeud que l'on a cree 1207 : DO 37 I=NPTINI+1,XCOOR(/1)/(IDIM+1) 1208 : XCOOR(I*(IDIM+1))=DENSI(ICPR(I,1)) 1209 : 37 CONTINUE 1210 : C 1211 : C======================================================================= 1212 : C Fin du programme 1213 : C======================================================================= 1214 : 998 CONTINUE 1214 : CALL ECROBJ('MAILLAGE',MELEME) 1215 : RETURN 1216 : END 1217 : 1218 : 1219 : 1220 : 1221 : 1222 : 1223 : 1224 : 1225 : 1226 :
© Cast3M 2003 - All rights reserved.
Disclaimer