1 : C RAFPYR SOURCE CHAT 11/03/16 21:30:15 6902 2 : SUBROUTINE RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE,MELVA2,NACREE, 3 : .KARAF,IPT4,JPLANS,JPLAN3,JPLCOM,JNOEFA,IPT7,JFARAF,KARET2,IPT5) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : IMPLICIT INTEGER(I-N) 6 : -INC CCOPTIO 7 : -INC SMCOORD 8 : -INC CCGEOME 9 : -INC SMELEME 10 : -INC SMCHPOI 11 : -INC SMMODEL 12 : -INC SMCHAML 13 : C 14 : C====================================================================== 15 : C Declarations 16 : C====================================================================== 17 : SEGMENT ICPR((XCOOR(/1)/(IDIM+1)),2) 18 : SEGMENT KARETE(NBNDS,NCOL) 19 : SEGMENT KARET2(NBNDS,NCOL) 20 : SEGMENT KMILIE(NBNDS,NCOL) 21 : SEGMENT KARPOS(NBNDS) 22 : SEGMENT JPLANS(JPLA1,JPLA2) 23 : SEGMENT JPLAN3(JPLA1,JPLA2) 24 : SEGMENT JPLCOM(JPLA1) 25 : SEGMENT JNOEFA(JNBFA,5) 26 : SEGMENT JFARAF(JNBFA,LLLL) 27 : SEGMENT NUMNOE(INUMNO) 28 : SEGMENT IWORK2(JNBSOM) 29 : SEGMENT IWORK1(IJKLMN) 30 : C 31 : C==================================================================== 32 : C Initialisations 33 : C==================================================================== 34 : SEGACT JPLANS,JPLCOM,JNOEFA,JPLAN3*MOD 35 : SEGACT IPT2,ICPR,KARPOS,KARETE,KMILIE*MOD,MELVA2,JFARAF*MOD 36 : IJKLMN=4 37 : ipt7=0 38 : SEGINI IWORK1 39 : IWORK1(1)=4 40 : IWORK1(2)=8 41 : IWORK1(3)=6 42 : IWORK1(4)=10 43 : NCOMPL=LNELM(1,(IPT2.ITYPEL-1)*2+2) 44 : C 45 : MBOUCL=0 46 : NBPYR=0 47 : 52 CONTINUE 48 : MBOUCL=MBOUCL+1 49 : C 50 : NBNN=NBNNE(LNELM(2,(IPT2.ITYPEL-1)*2+1)) 51 : INELM=LNELM(1,(IPT2.ITYPEL-1)*2+1) 52 : C 53 : C Creation du squelette du maillage resultat 54 : NBELEM=IPT2.NUM(/2)-KARAF+INELM*KARAF 55 : NBSOUS=0 56 : NBREF=0 57 : SEGINI IPT4 58 : IPT4.ITYPEL=LNELM(2,(IPT2.ITYPEL-1)*2+1) 59 : LPO2=LPOS2(IPT2.ITYPEL) 60 : NBPT0=XCOOR(/1)/(IDIM+1) 61 : NBPT1=XCOOR(/1)/(IDIM+1) 62 : NBPTS=NBPT1+NACREE+KARAF*NBINTE(IPT2.ITYPEL) 63 : SEGADJ MCOORD 64 : INUMNO=NBRAF(IPT2.ITYPEL) 65 : SEGINI NUMNOE 66 : LCOMP=1 67 : C 68 : NCOMPT=0 69 : DO 53 IARAF=1,MELVA2.VELCHE(/2) 70 : IF (MELVA2.VELCHE(1,IARAF).EQ.1) NCOMPT=NCOMPT+1 71 : 53 CONTINUE 72 : NUELM=1 73 : NBNN=NBNNE(IPT2.ITYPEL-2) 74 : NBELEM=NCOMPT*4 75 : NBSOUS=0 76 : NBREF=0 77 : SEGINI IPT5 78 : IPT5.ITYPEL=IPT2.ITYPEL-2 79 : C 80 : C 81 : C====================================================================== 82 : C Phase de raffinement 3D 83 : C====================================================================== ! 84 : C======================================= 85 : C A) Boucle sur les elements a raffiner ! 86 : C======================================= 87 : DO 6 IARAF=1,MELVA2.VELCHE(/2) 88 : IF (MELVA2.VELCHE(1,IARAF).NE.1) THEN 89 : DO 1 IJKL=1,IPT2.NUM(/1) 90 : IPT4.NUM(IJKL,NBELEM)=IPT2.NUM(IJKL,IARAF) 91 : 1 CONTINUE 92 : NBELEM=NBELEM-1 93 : GOTO 6 94 : ENDIF 95 : NBPYR=NBPYR+1 96 : JCOMPT=0 97 : JPOS5=LPOS5(IPT2.ITYPEL) 98 : C 99 : C========================================================== 100 : C B) Boucle sur les noeuds a creer pour raffiner l'element ! 101 : C========================================================== 102 : DO 4 I=1,NBRAF(IPT2.ITYPEL) 103 : JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) 104 : JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) 105 : JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT 106 : LTYPNO=JTYPNO(JPOS5-1+I) 107 : C 108 : C------------------------------- 109 : C ** B.1 / On est sur une arete ! 110 : C------------------------------- 111 : IF (LTYPNO.EQ.0) THEN 112 : NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) 113 : NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) 114 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 115 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 116 : DO 2 K=1,MAX(1,KARPOS(NMIN)) 117 : IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 118 : 2 CONTINUE 119 : IF (KMILIE(NMIN,NEXIST).GT.0) THEN 120 : NUMNOE(I)=KMILIE(NMIN,NEXIST) 121 : JCOMPT=JCOMPT+JLONG 122 : GOTO 4 123 : ELSE 124 : NBPT1=NBPT1+1 125 : NUMNOE(I)=NBPT1 126 : KMILIE(NMIN,NEXIST)=NBPT1 127 : ENDIF 128 : C 129 : C------------------------------ 130 : C ** B.2 / On est sur une face ! 131 : C------------------------------ 132 : C Il faut identifier cette face (numero, sommets...) 133 : ELSEIF ((LTYPNO.GT.0).AND.(LTYPNO.LT.7)) THEN 134 : C => a) On initialise toutes les donnees relatives a cette face 135 : JTYPEL=IPT2.ITYPEL 136 : JLTEL2=LTEL(1,JTYPEL)-1+LTYPNO 137 : JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO 138 : JLDEL1=LDEL(1,JLTEL2) 139 : JTYFAC=IWORK1(JLDEL1) 140 : JLDEL2=LDEL(2,JLTEL2) 141 : JNBSOM=NBSOM(JTYFAC) 142 : JSPOS=NSPOS(JTYFAC) 143 : C => b) On identifie les sommets de la face (n° global) 144 : SEGINI IWORK2 145 : DO 10 IAA=1,JNBSOM 146 : NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF) 147 : IWORK2(IAA)=NGLOBA 148 : 10 CONTINUE 149 : C => c) On classe ces sommets par ordre croissant (NPTA < NPTB < NPTC) 150 : NPTA=(XCOOR(/1)/(IDIM+1))+1 151 : NPTB=NPTA+1 152 : NPTC=NPTB+1 153 : DO 11 ICC=1,JNBSOM 154 : IF (IWORK2(ICC).LT.NPTA) THEN 155 : NPTC=NPTB 156 : NPTB=NPTA 157 : NPTA=IWORK2(ICC) 158 : ELSEIF (IWORK2(ICC).LT.NPTB) THEN 159 : NPTC=NPTB 160 : NPTB=IWORK2(ICC) 161 : ELSEIF (IWORK2(ICC).LT.NPTC) THEN 162 : NPTC=IWORK2(ICC) 163 : ENDIF 164 : 11 CONTINUE 165 : C => d) On passe ces sommets en n° locale 166 : NPTA2=ICPR(NPTA,1) 167 : NPTB2=ICPR(NPTB,1) 168 : NPTC2=ICPR(NPTC,1) 169 : IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN 170 : NPTA=NPTA2 171 : NPTB=MIN(NPTB2,NPTC2) 172 : NPTC=MAX(NPTB2,NPTC2) 173 : ENDIF 174 : IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN 175 : NPTA=NPTB2 176 : NPTB=MIN(NPTA2,NPTC2) 177 : NPTC=MAX(NPTA2,NPTC2) 178 : ENDIF 179 : IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN 180 : NPTA=NPTC2 181 : NPTB=MIN(NPTA2,NPTB2) 182 : NPTC=MAX(NPTA2,NPTB2) 183 : ENDIF 184 : C => e) On cherche le numero de la face 185 : NEXIS2=0 186 : DO 12 IEE=1,JPLCOM(NPTA) 187 : MTMP=JPLANS(NPTA,IEE) 188 : JJ1=JNOEFA(MTMP,1) 189 : JJ2=JNOEFA(MTMP,2) 190 : JJ3=JNOEFA(MTMP,3) 191 : IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN 192 : NEXIS2=IEE 193 : ENDIF 194 : 12 CONTINUE 195 : JNUMFA=JPLANS(NPTA,NEXIS2) 196 : C 197 : C--------------------------------- 198 : C ** B.3 / Raffinement de la face ! 199 : C--------------------------------- 200 : KTEST1=JPLAN3(NPTA,NEXIS2) 201 : KTEST2=NBINTE(JTYFAC) 202 : C => a) Si la face est de type QUA4 (un seul noeud a creer, au milieu) 203 : IF (JTYFAC.EQ.8) THEN 204 : IF (KTEST1.LT.KTEST2) THEN 205 : NBPT1=NBPT1+1 206 : NUMNOE(I)=NBPT1 207 : JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1 208 : JFARAF(JNUMFA,1)=NBPT1 209 : ELSEIF (KTEST1.EQ.KTEST2) THEN 210 : NUMNOE(I)=JFARAF(JNUMFA,1) 211 : JFARAF(JNUMFA,1)=0 212 : JCOMPT=JCOMPT+JLONG 213 : GOTO 4 214 : ELSE 215 : WRITE(*,*) 'ERREUR' 216 : ENDIF 217 : ENDIF 218 : C => b) Si la face n'est pas de type QUA4 (donc de type TRI6 ou QUA8) 219 : IF (JTYFAC.NE.8) THEN 220 : IF (KTEST1.LT.KTEST2) THEN 221 : NBPT1=NBPT1+1 222 : NUMNOE(I)=NBPT1 223 : JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1 224 : NEXIS3=0 225 : XCO2=0.25 226 : DO 13 KBB=1,JLONG 227 : XCO1=XCOEFF(JPOS1-1+KBB) 228 : IF (XCO1.EQ.XCO2) NEXIS3=KBB 229 : 13 CONTINUE 230 : JFARAF(JNUMFA,2*(KTEST1)+1)=NBPT1 231 : IF (NEXIS3.NE.0) THEN 232 : NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) 233 : JFARAF(JNUMFA,2*(KTEST1)+2)=NGLOB 234 : ELSE 235 : JFARAF(JNUMFA,2*(KTEST1)+2)=0 236 : ENDIF 237 : ELSEIF (KTEST1.EQ.KTEST2) THEN 238 : NEXIS3=0 239 : NEXIS4=0 240 : XCO2=0.25 241 : DO 14 KBB=1,JLONG 242 : XCO1=XCOEFF(JPOS1-1+KBB) 243 : IF (XCO1.EQ.XCO2) NEXIS3=KBB 244 : 14 CONTINUE 245 : IF (NEXIS3.NE.0) THEN 246 : NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) 247 : DO 15 KAA=2,JFARAF(/2),2 248 : IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA 249 : 15 CONTINUE 250 : NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1) 251 : JFARAF(JNUMFA,NEXIS4-1)=0 252 : ELSE 253 : DO 16 KAA=2,JFARAF(/2),2 254 : IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA 255 : 16 CONTINUE 256 : NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1) 257 : JFARAF(JNUMFA,NEXIS4-1)=0 258 : ENDIF 259 : JCOMPT=JCOMPT+JLONG 260 : GOTO 4 261 : ENDIF 262 : ENDIF 263 : C 264 : C------------------------------------------------------ 265 : C ** B.4 / On est a l'interieur du volume de l'element ! 266 : C------------------------------------------------------ 267 : ELSEIF (LTYPNO.EQ.7) THEN 268 : NBPT1=NBPT1+1 269 : NUMNOE(I)=NBPT1 270 : ENDIF 271 : C 272 : IF (NBPT1.EQ.NBPTS) THEN 273 : NBPTS=NBPTS+200 274 : SEGADJ MCOORD 275 : ENDIF 276 : C 277 : C============================== 278 : C C) Creation du nouveau point ! 279 : C============================== 280 : C On continue ici que lorsque l'on doit creer un nouveau point 281 : XPT=0. 282 : YPT=0. 283 : ZPT=0. 284 : DO 3 J=1,JLONG 285 : NGLOB=IPT2.NUM(LISNOE(JLISN-1+J),IARAF) 286 : XINI=XCOOR((NGLOB-1)*(IDIM+1)+1) 287 : YINI=XCOOR((NGLOB-1)*(IDIM+1)+2) 288 : ZINI=XCOOR((NGLOB-1)*(IDIM+1)+3) 289 : XPT=XPT+XINI*XCOEFF(JPOS1-1+J) 290 : YPT=YPT+YINI*XCOEFF(JPOS1-1+J) 291 : ZPT=ZPT+ZINI*XCOEFF(JPOS1-1+J) 292 : 3 CONTINUE 293 : XCOOR((NBPT1-1)*(IDIM+1)+1)=XPT 294 : XCOOR((NBPT1-1)*(IDIM+1)+2)=YPT 295 : XCOOR((NBPT1-1)*(IDIM+1)+3)=ZPT 296 : JCOMPT=JCOMPT+JLONG 297 : 4 CONTINUE 298 : JPOS4=LPOS4(IPT2.ITYPEL) 299 : C 300 : C=================================== 301 : C D) Creation des nouveaux elements ! 302 : C=================================== 303 : C On remplit la portion de IPT4 relative aux elements crees a partir 304 : C de la division de l'element IARAF (indice de boucle 1). 305 : C Cette portion de IPT4 contient les colonnes dont la valeur s'etend 306 : C de INELM*(LCOMP-1)+1 a INELM*LCOMP. 307 : NBNN=NBNNE(LNELM(2,(KTYP-1)*2+1)) 308 : DO 5 J=1,INELM 309 : DO 5 I=1,IPT4.NUM(/1) 310 : NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I) 311 : IF (NTEMP.GT.NBNN) THEN 312 : IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN) 313 : ELSE 314 : IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF) 315 : ENDIF 316 : 5 CONTINUE 317 : LCOMP=LCOMP+1 318 : C 319 : KTYP=IPT2.ITYPEL 320 : IF (KTYP.EQ.25) JPOS41=561+5*6 321 : IF (KTYP.EQ.26) JPOS41=685 322 : DO 34 JJ=1,IPT5.NUM(/2) 323 : DO 33 II=1,IPT5.NUM(/1) 324 : NTEMP=LIELM(JPOS41-1+II) 325 : IF (NTEMP.GT.NBNN) THEN 326 : IPT5.NUM(II,NUELM)=NUMNOE(NTEMP-NBNN) 327 : ELSE 328 : IPT5.NUM(II,NUELM)=IPT2.NUM(NTEMP,IARAF) 329 : ENDIF 330 : 33 CONTINUE 331 : JPOS41=JPOS41+NBNNE(KTYP-2) 332 : NUELM=NUELM+1 333 : 34 CONTINUE 334 : C 335 : 6 CONTINUE 336 : C 337 : NBPTS=NBPT1 338 : SEGADJ MCOORD 339 : C 340 : C======================================================================= 341 : C Preparation du maillage de relations 342 : C======================================================================= 343 : C================================== 344 : C A) Relations dues aux faces (3D) ! 345 : C================================== 346 : C Tous les noeuds qui restent dans JFARAF sont a creer en tant que 347 : C relations de conformite 348 : C--------------------------------- 349 : C ** A.1 / Initialisation de IPT5 ! 350 : C--------------------------------- 351 : C 1/ Comptage du nombre de noeuds soumis a des relations 352 : NBRELA=0 353 : DO 114 IHF=1,JFARAF(/1) 354 : IF (JNOEFA(IHF,5).EQ.0) GOTO 114 355 : IF (JFARAF(IHF,1).EQ.0) GOTO 114 356 : DO 113 JF=1,JFARAF(/2),2 357 : IF (JFARAF(IHF,JF).NE.0) NBRELA=NBRELA+1 358 : 113 CONTINUE 359 : 114 CONTINUE 360 : C 361 : C 2/ Creation de IPT5 362 : IF (NBRELA.EQ.0) THEN 363 : IPT5=0 364 : GOTO 210 365 : ENDIF 366 : C IF (IPT2.ITYPEL.EQ.14) NBNN=4 367 : C IF (IPT2.ITYPEL.EQ.15) NBNN=8 368 : C IF (IPT2.ITYPEL.EQ.17) NBNN=5 369 : C IF (IPT2.ITYPEL.EQ.24) NBNN=5 370 : NBNN=10 371 : NBELEM=NBRELA 372 : NBSOUS=0 373 : NBREF=0 374 : SEGINI IPT5 375 : IPT5.ITYPEL=48 376 : C 377 : C 3/ Renseignement des noeuds support des relations 378 : NBRELA=0 379 : DO 116 IPF=1,JFARAF(/1) 380 : IF (JNOEFA(IPF,5).EQ.0) GOTO 116 381 : IF (JFARAF(IPF,1).EQ.0) GOTO 116 382 : DO 115 JF=1,JFARAF(/2),2 383 : IF (JFARAF(IPF,JF).EQ.0) GOTO 115 384 : NBRELA=NBRELA+1 385 : IPT5.NUM(1,NBRELA)=JFARAF(IPF,JF) 386 : 115 CONTINUE 387 : 116 CONTINUE 388 : C 389 : C----------------------------------------------------- 390 : C ** A.2 / Recherche des noeuds formant les relations ! 391 : C----------------------------------------------------- 392 : C 1/ Boucle sur l'ensemble des noeuds a creer 393 : DO 200 IARAF=1,MELVA2.VELCHE(/2) 394 : IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 200 395 : JCOMPT=0 396 : JPOS5=LPOS5(IPT2.ITYPEL) 397 : DO 190 I=1,NBRAF(IPT2.ITYPEL) 398 : JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) 399 : JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) 400 : JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT 401 : LTYPNO=JTYPNO(JPOS5-1+I) 402 : IF ((LTYPNO.EQ.0).OR.(LTYPNO.EQ.7)) GOTO 189 403 : C 404 : C 2/ Preparation pour trouver le noeud et la face en question 405 : JTYPEL=IPT2.ITYPEL 406 : JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO 407 : JLDEL1=LDEL(1,JLTEL2) 408 : JTYFAC=IWORK1(JLDEL1) 409 : JLDEL2=LDEL(2,JLTEL2) 410 : JNBSOM=NBSOM(JTYFAC) 411 : JSPOS=NSPOS(JTYFAC) 412 : SEGINI IWORK2 413 : C 414 : C 3/ Classement des 3 sommets par ordre croissant de n° globale 415 : DO 100 IAA=1,JNBSOM 416 : NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF) 417 : IWORK2(IAA)=NGLOBA 418 : 100 CONTINUE 419 : NPTA=(XCOOR(/1)/(IDIM+1))+1 420 : NPTB=NPTA+1 421 : NPTC=NPTB+1 422 : DO 110 ICC=1,JNBSOM 423 : IF (IWORK2(ICC).LT.NPTA) THEN 424 : NPTC=NPTB 425 : NPTB=NPTA 426 : NPTA=IWORK2(ICC) 427 : ELSEIF (IWORK2(ICC).LT.NPTB) THEN 428 : NPTC=NPTB 429 : NPTB=IWORK2(ICC) 430 : ELSEIF (IWORK2(ICC).LT.NPTC) THEN 431 : NPTC=IWORK2(ICC) 432 : ENDIF 433 : 110 CONTINUE 434 : C 435 : C 4/ Classement des 3 sommets par ordre croissant de n° locale 436 : NPTA2=ICPR(NPTA,1) 437 : NPTB2=ICPR(NPTB,1) 438 : NPTC2=ICPR(NPTC,1) 439 : IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN 440 : NPTA=NPTA2 441 : NPTB=MIN(NPTB2,NPTC2) 442 : NPTC=MAX(NPTB2,NPTC2) 443 : ENDIF 444 : IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN 445 : NPTA=NPTB2 446 : NPTB=MIN(NPTA2,NPTC2) 447 : NPTC=MAX(NPTA2,NPTC2) 448 : ENDIF 449 : IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN 450 : NPTA=NPTC2 451 : NPTB=MIN(NPTA2,NPTB2) 452 : NPTC=MAX(NPTA2,NPTB2) 453 : ENDIF 454 : C 455 : C 5/ Recherche du numero de la face 456 : NEXIS2=0 457 : DO 120 IEE=1,JPLCOM(NPTA) 458 : MTMP=JPLANS(NPTA,IEE) 459 : JJ1=JNOEFA(MTMP,1) 460 : JJ2=JNOEFA(MTMP,2) 461 : JJ3=JNOEFA(MTMP,3) 462 : IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN 463 : NEXIS2=IEE 464 : ENDIF 465 : 120 CONTINUE 466 : JNUMFA=JPLANS(NPTA,NEXIS2) 467 : C 468 : C 6/ Recherche du numero global du point 469 : IF (JNOEFA(JNUMFA,5).EQ.0) GOTO 189 470 : IF (JTYFAC.EQ.8) INOEGL=JFARAF(JNUMFA,1) 471 : IF (JTYFAC.NE.8) THEN 472 : NEXIS3=0 473 : NEXIS4=0 474 : XCO2=0.25 475 : DO 140 KBB=1,JLONG 476 : XCO1=XCOEFF(JPOS1-1+KBB) 477 : IF (XCO1.EQ.XCO2) NEXIS3=KBB 478 : 140 CONTINUE 479 : IF (NEXIS3.NE.0) THEN 480 : NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) 481 : DO 150 KAA=2,JFARAF(/2),2 482 : IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA 483 : 150 CONTINUE 484 : INOEGL=JFARAF(JNUMFA,NEXIS4-1) 485 : ELSE 486 : DO 160 KAA=2,JFARAF(/2),2 487 : IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA 488 : 160 CONTINUE 489 : INOEGL=JFARAF(JNUMFA,NEXIS4-1) 490 : ENDIF 491 : ENDIF 492 : C 493 : C------------------------------ 494 : C ** A.3 / Remplissage de IPT5 ! 495 : C------------------------------ 496 : C 1/ Recherche de la position du point dans IPT5 497 : NEXIS5=0 498 : DO 170 IGG=1,IPT5.NUM(/2) 499 : IF (INOEGL.EQ.IPT5.NUM(1,IGG)) NEXIS5=IGG 500 : 170 CONTINUE 501 : IF (NEXIS5.EQ.0) GOTO 189 502 : C 503 : C 2/ Renseignement des points formant les relations 504 : DO 180 IHH=1,JLONG 505 : IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF) 506 : 180 CONTINUE 507 : IF (JLONG.EQ.4) IPT5.NUM(10,NEXIS5)=3 508 : IF (JLONG.EQ.5) IPT5.NUM(10,NEXIS5)=4 509 : IF (JLONG.EQ.8) THEN 510 : IF (JPOS1.EQ.16) IPT5.NUM(10,NEXIS5)=5 511 : IF (JPOS1.EQ.24) IPT5.NUM(10,NEXIS5)=6 512 : ENDIF 513 : 189 CONTINUE 514 : JCOMPT=JCOMPT+JLONG 515 : 190 CONTINUE 516 : 200 CONTINUE 517 : 210 CONTINUE 518 : C 519 : C=================================== 520 : C B) Relations dues aux aretes (2D) ! 521 : C=================================== 522 : C On cree un maillage IPT6 contenant tous les noeuds soumis a des 523 : C relations 524 : C 525 : SEGSUP KARET2 526 : NBNDS=KARETE(/1) 527 : NCOL=KARETE(/2) 528 : SEGINI KARET2 529 : ILPL=LPL(IPT2.ITYPEL) 530 : ILPT=LPT(IPT2.ITYPEL) 531 : DO 317 J=1,IPT4.NUM(/2) 532 : DO 317 K=1,ILPL*2-1,2 533 : NPTA=IPT4.NUM(KSEGM(ILPT+K-1),J) 534 : NPTB=IPT4.NUM(KSEGM(ILPT+K),J) 535 : IF((NPTA.GT.NBPT0).OR.(NPTB.GT.NBPT0)) THEN 536 : GOTO 317 537 : ENDIF 538 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 539 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 540 : NEXIST=0 541 : DO 316 I=1,MAX(1,KARPOS(NMIN)) 542 : IF (KARETE(NMIN,I).EQ.NMAX) THEN 543 : KARET2(NMIN,I)=KARET2(NMIN,I)+1 544 : ENDIF 545 : 316 CONTINUE 546 : 317 CONTINUE 547 : 548 : C 1/ Comptage du nombre de noeuds soumis a des relations 549 : NBELEM=0 550 : DO 27 J=1,KMILIE(/2) 551 : DO 27 I=1,KMILIE(/1) 552 : IF (KARET2(I,J).EQ.0) GOTO 27 553 : IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1 554 : 27 CONTINUE 555 : C 556 : C 2/ Creation de IPT6 557 : IPT6=0 558 : IF (NBELEM.EQ.0) GOTO 999 559 : NBNN=5 560 : NBREF=0 561 : NBSOUS=0 562 : SEGINI IPT6 563 : IPT6.ITYPEL=48 564 : C 565 : C 3/ Renseignement des noeuds support des relations 566 : DO 28 J=1,KMILIE(/2) 567 : DO 28 I=1,KMILIE(/1) 568 : IF (KARET2(I,J).EQ.0) GOTO 28 569 : IF (KMILIE(I,J).GT.0) THEN 570 : NBREF=NBREF+1 571 : IPT6.NUM(1,NBREF)=KMILIE(I,J) 572 : ENDIF 573 : 28 CONTINUE 574 : C 575 : C 4/ Recherche des noeuds formant les relations 576 : DO 24 IARAF=1,MELVA2.VELCHE(/2) 577 : IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 24 578 : JCOMPT=0 579 : JPOS5=LPOS5(IPT2.ITYPEL) 580 : DO 23 I=1,NBRAF(IPT2.ITYPEL) 581 : JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) 582 : JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) 583 : JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT 584 : LTYPNO=JTYPNO(JPOS5-1+I) 585 : IF (LTYPNO.NE.0) GOTO 22 586 : NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) 587 : NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) 588 : NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) 589 : NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) 590 : DO 29 K=1,MAX(1,KARPOS(NMIN)) 591 : IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 592 : 29 CONTINUE 593 : IF (KARET2(NMIN,NEXIST).EQ.0) GOTO 22 594 : IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 22 595 : NEXIS5=0 596 : DO 20 MM=1,IPT6.NUM(/2) 597 : INOEGL=KMILIE(NMIN,NEXIST) 598 : INRELA=IPT6.NUM(1,MM) 599 : IF (INOEGL.EQ.INRELA) NEXIS5=MM 600 : 20 CONTINUE 601 : C 602 : C 5/ Renseignement des noeuds formant les relations 603 : DO 21 IHH=1,JLONG 604 : IPT6.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF) 605 : 21 CONTINUE 606 : IF (JLONG.EQ.2) IPT6.NUM(5,NEXIS5)=1 607 : IF (JLONG.EQ.3) IPT6.NUM(5,NEXIS5)=2 608 : 22 CONTINUE 609 : JCOMPT=JCOMPT+JLONG 610 : 23 CONTINUE 611 : 24 CONTINUE 612 : 613 : 444 CONTINUE 614 : 615 : C 616 : C============================================ 617 : C C) Creation du maillage de relations final ! 618 : C============================================ 619 : IF (IPT5.EQ.0) THEN 620 : IPT7=IPT6 621 : GOTO 999 622 : ENDIF 623 : NBELEM=IPT5.NUM(/2)+IPT6.NUM(/2) 624 : C NBNN=MAX(IPT5.NUM(/1),IPT6.NUM(/1)) 625 : NBNN=10 626 : NBREF=0 627 : NBSOUS=0 628 : SEGINI IPT7 629 : IPT7.ITYPEL=48 630 : DO 42 NEO=1,IPT5.NUM(/2) 631 : DO 42 MOR=1,10 632 : IPT7.NUM(MOR,NEO)=IPT5.NUM(MOR,NEO) 633 : IPT7.ICOLOR(NEO)=IPT5.ICOLOR(NEO) 634 : 42 CONTINUE 635 : NN5 = IPT5.NUM(/2) 636 : DO 43 NEO=IPT5.NUM(/2)+1,IPT6.NUM(/2)+IPT5.NUM(/2) 637 : DO 43 MOR=1,IPT6.NUM(/1) 638 : IF (MOR.LT.IPT6.NUM(/1)) THEN 639 : IPT7.NUM(MOR,NEO)=IPT6.NUM(MOR,NEO-NN5) 640 : ELSE 641 : IPT7.NUM(10,NEO)=IPT6.NUM(MOR,NEO-NN5) 642 : ENDIF 643 : IPT7.ICOLOR(NEO)=IPT6.ICOLOR(NEO-NN5) 644 : 43 CONTINUE 645 : WRITE(*,*) ' |-> raffinement OK' 646 : C======================================================================= 647 : C Fin du programme 648 : C======================================================================= 649 : GOTO 999 650 : WRITE(*,*) '****************************************************' 651 : WRITE(*,*) 'TABLEAU JNOEFA' 652 : DO 64 I=1,JNOEFA(/1) 653 : WRITE(*,1000) I,':',(JNOEFA(I,J), J=1,JNOEFA(/2)) 654 : 64 CONTINUE 655 : WRITE(*,*) '****************************************************' 656 : WRITE(*,*) 'TABLEAU JFARAF' 657 : WRITE(*,*) 'Nb colonnes = ',JFARAF(/2) 658 : DO 63 I=1,JFARAF(/1) 659 : WRITE(*,1000) I,':',(JFARAF(I,J), J=1,JFARAF(/2)) 660 : 63 CONTINUE 661 : GOTO 999 662 : WRITE(*,*) '****************************************************' 663 : WRITE(*,*) 'TABLEAU JPLANS' 664 : DO 61 I=1,JPLANS(/1) 665 : WRITE(*,1000) I,':',(JPLANS(I,J), J=1,JPLANS(/2)) 666 : 61 CONTINUE 667 : WRITE(*,*) '****************************************************' 668 : WRITE(*,*) 'TABLEAU JPLAN3' 669 : DO 62 I=1,JPLAN3(/1) 670 : WRITE(*,1000) I,':',(JPLAN3(I,J), J=1,JPLAN3(/2)) 671 : 62 CONTINUE 672 : WRITE(*,*) '****************************************************' 673 : WRITE(*,*) 'TABLEAU ICPR' 674 : DO 98 I=1,ICPR(/1) 675 : WRITE(*,*) I,': ',ICPR(I,1),' ',ICPR(I,2) 676 : 98 CONTINUE 677 : 1000 FORMAT (1I3,A,24I4) 678 : 999 CONTINUE 679 : RETURN 680 : END 681 : 682 : 683 : 684 : 685 :
© Cast3M 2003 - All rights reserved.
Disclaimer