1 : C ENVVOL SOURCE BP208322 11/12/12 21:15:04 7202 2 : SUBROUTINE ENVVOL 3 : 4 : IMPLICIT INTEGER(I-N) 5 : 6 : -INC CCOPTIO 7 : -INC SMELEME 8 : -INC CCGEOME 9 : -INC SMCOORD 10 : 11 : SEGMENT IFAC3(4,NFAC3) 12 : SEGMENT IFAC4(5,NFAC4) 13 : SEGMENT IFAC6(7,NFAC6) 14 : SEGMENT IFAC8(9,NFAC8) 15 : SEGMENT IPPOL(NTPOL) 16 : SEGMENT NTFAC(NFAC) 17 : SEGMENT KFAK(NFAC) 18 : SEGMENT NAUX(NFAC) 19 : SEGMENT XCENT(3,NBELEM) 20 : 21 : c==== LECTURE D UN MOT CLE ORIE pour ORIENTER L ENVELOPPE ============= 22 : PARAMETER (LCLE = 1) 23 : CHARACTER*4 MCLE(LCLE) 24 : DATA MCLE/'ORIE'/ 25 : ICLE=0 25 : CALL LIRMOT(MCLE,LCLE,ICLE,0) 26 : 27 : c==== LECTURE ET OUVERTURE DU MELEME ================================== 28 : c et eventuelle boucle 10 sur les ojbets meleme elementaires 28 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 29 : IF (IERR.NE.0) RETURN 30 : SEGACT MELEME 31 : c on compte le nombre d elements dont les faces possedent 3,4,6 ou 8 32 : c noeuds => NFAC3,4,6,8 33 : NFAC3=0 34 : NFAC4=0 35 : NFAC6=0 36 : NFAC8=0 37 : NTPOL = 0 38 : IPT1=MELEME 39 : SEGACT MELEME 40 : DO 10 IOB=1,MAX(1,LISOUS(/1)) 41 : IF (LISOUS(/1).NE.0) THEN 42 : IPT1=LISOUS(IOB) 43 : SEGACT IPT1 44 : ENDIF 45 : NBELEM=IPT1.NUM(/2) 46 : c LTEL,LDEL LFAC de CCGEOME remplis par bdata 47 : ILTEL=LTEL(1,IPT1.ITYPEL) 48 : IF (ILTEL.EQ.0) GOTO 12 49 : ILTAD=LTEL(2,IPT1.ITYPEL) 50 : c --- boucle sur les faces de chaque elements --- 51 : DO 13 IF=1,ILTEL 52 : IFT=LDEL(1,ILTAD+IF-1) 53 : GOTO (21,22,23,24,25,26),IFT 54 : 21 NFAC3=NFAC3+NBELEM 55 : GOTO 30 56 : 22 NFAC4=NFAC4+NBELEM 57 : GOTO 30 58 : 23 NFAC6=NFAC6+NBELEM 59 : GOTO 30 60 : 24 NFAC8=NFAC8+NBELEM 61 : GOTO 30 62 : 25 GOTO 30 63 : 26 NTPOL = NTPOL+1 64 : GOTO 30 65 : 30 CONTINUE 66 : 13 CONTINUE 67 : c --- fin de boucle sur les faces de chaque elements --- 68 : 12 CONTINUE 69 : 10 CONTINUE 70 : c write(6,*) 'dimension de NFAC3,4,6,8=',NFAC3,NFAC4,NFAC6,NFAC8 71 : 72 : c==== CREATION DES FACES ============================================== 73 : c IFAC3,4,6,8(i,j)=noeuds de la jieme face 74 : SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IPPOL 75 : NFAC3=0 76 : NFAC4=0 77 : NFAC6=0 78 : NFAC8=0 79 : NTPOL=0 80 : c eventuelle boucle 50 sur les ojbets meleme elementaires 81 : DO 50 IOB=1,MAX(1,LISOUS(/1)) 82 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(IOB) 83 : segact ipt1 84 : NBELEM=IPT1.NUM(/2) 85 : C calcul du centre des noeuds des elements 86 : if (ICLE.eq.1) then 87 : segini,XCENT 88 : NBNN=IPT1.NUM(/1) 89 : IDIM1 = IDIM+1 90 : do iel=1,NBELEM 91 : XG = 0.D0 92 : YG = 0.D0 93 : ZG = 0.D0 94 : do inode=1,NBNN 95 : IP1 = IPT1.NUM(inode,iel) - 1 96 : XG = XG + XCOOR(IP1*IDIM1+1) 97 : YG = YG + XCOOR(IP1*IDIM1+2) 98 : ZG = ZG + XCOOR(IP1*IDIM1+3) 99 : enddo 100 : XCENT(1,iel)=XG/NBNN 101 : XCENT(2,iel)=YG/NBNN 102 : XCENT(3,iel)=ZG/NBNN 103 : enddo 104 : c write(6,*) 'XCENT=',(XCENT(1,iou),iou=1,min(4,NBELEM)) 105 : c write(6,*) ' ',(XCENT(2,iou),iou=1,min(4,NBELEM)) 106 : c write(6,*) ' ',(XCENT(3,iou),iou=1,min(4,NBELEM)) 107 : endif 108 : ILTEL=LTEL(1,IPT1.ITYPEL) 109 : IF (ILTEL.EQ.0) GOTO 52 110 : ILTAD=LTEL(2,IPT1.ITYPEL) 111 : c --- boucle 60 sur faces d'1 type d'element ------------------ 112 : DO 60 IF=1,ILTEL 113 : ITYP=LDEL(1,ILTAD+IF-1) 114 : IAD=LDEL(2,ILTAD+IF-1) 115 : c --- boucle 66 sur elements --------------------------------- 116 : DO 66 IEL=1,NBELEM 117 : GOTO (61,62,63,64,65,65),ITYP 118 : 61 NFAC3=NFAC3+1 119 : IFAC3(1,NFAC3)=IPT1.NUM(LFAC(IAD),IEL) 120 : IFAC3(2,NFAC3)=IPT1.NUM(LFAC(IAD+1),IEL) 121 : IFAC3(3,NFAC3)=IPT1.NUM(LFAC(IAD+2),IEL) 122 : IFAC3(4,NFAC3)=IPT1.ICOLOR(IEL) 122 : if(ICLE.eq.1) call envori(IFAC3,0,0,0,NFAC3,XCENT,IEL) 123 : GOTO 65 124 : 62 NFAC4=NFAC4+1 125 : IFAC4(1,NFAC4)=IPT1.NUM(LFAC(IAD),IEL) 126 : IFAC4(2,NFAC4)=IPT1.NUM(LFAC(IAD+1),IEL) 127 : IFAC4(3,NFAC4)=IPT1.NUM(LFAC(IAD+2),IEL) 128 : IFAC4(4,NFAC4)=IPT1.NUM(LFAC(IAD+3),IEL) 129 : IFAC4(5,NFAC4)=IPT1.ICOLOR(IEL) 129 : if(ICLE.eq.1) call envori(0,IFAC4,0,0,NFAC4,XCENT,IEL) 130 : GOTO 65 131 : 63 NFAC6=NFAC6+1 132 : IFAC6(1,NFAC6)=IPT1.NUM(LFAC(IAD) ,IEL) 133 : IFAC6(2,NFAC6)=IPT1.NUM(LFAC(IAD+1),IEL) 134 : IFAC6(3,NFAC6)=IPT1.NUM(LFAC(IAD+2),IEL) 135 : IFAC6(4,NFAC6)=IPT1.NUM(LFAC(IAD+3),IEL) 136 : IFAC6(5,NFAC6)=IPT1.NUM(LFAC(IAD+4),IEL) 137 : IFAC6(6,NFAC6)=IPT1.NUM(LFAC(IAD+5),IEL) 138 : IFAC6(7,NFAC6)=IPT1.ICOLOR(IEL) 138 : if(ICLE.eq.1) call envori(0,0,IFAC6,0,NFAC6,XCENT,IEL) 139 : GOTO 65 140 : 64 CONTINUE 141 : NFAC8=NFAC8+1 142 : IFAC8(1,NFAC8)=IPT1.NUM(LFAC(IAD) ,IEL) 143 : IFAC8(2,NFAC8)=IPT1.NUM(LFAC(IAD+1),IEL) 144 : IFAC8(3,NFAC8)=IPT1.NUM(LFAC(IAD+2),IEL) 145 : IFAC8(4,NFAC8)=IPT1.NUM(LFAC(IAD+3),IEL) 146 : IFAC8(5,NFAC8)=IPT1.NUM(LFAC(IAD+4),IEL) 147 : IFAC8(6,NFAC8)=IPT1.NUM(LFAC(IAD+5),IEL) 148 : IFAC8(7,NFAC8)=IPT1.NUM(LFAC(IAD+6),IEL) 149 : IFAC8(8,NFAC8)=IPT1.NUM(LFAC(IAD+7),IEL) 150 : IFAC8(9,NFAC8)=IPT1.ICOLOR(IEL) 150 : if(ICLE.eq.1) call envori(0,0,0,IFAC8,NFAC8,XCENT,IEL) 151 : GOTO 65 152 : 65 CONTINUE 153 : 66 CONTINUE 154 : c --- fin de boucle 66 sur elements --------------------------------- 155 : 60 CONTINUE 156 : c --- fin de boucle 60 sur faces d'1 type d'element ------------------ 157 : 52 CONTINUE 158 : IF (ITYP.EQ.6) THEN 159 : C Polygone 160 : NTPOL = NTPOL+1 161 : IPPOL(NTPOL)= IPT1 162 : ELSE 163 : IF (LISOUS(/1).NE.0) SEGDES IPT1 164 : ENDIF 165 : 50 CONTINUE 166 : SEGDES MELEME 167 : if (ICLE.eq.1) segsup,XCENT 168 : 169 : C ====================================================================== 170 : C IL FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES 171 : C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON 172 : NFAC=NFAC3+NFAC4+NFAC6+NFAC8 173 : SEGINI NTFAC,KFAK 174 : IF (NFAC3.EQ.0) GOTO 101 175 : DO 102 I=1,NFAC3 176 : NTFAC(I)=IFAC3(1,I)+IFAC3(2,I)+IFAC3(3,I) 177 : KFAK(I)=I 178 : 102 CONTINUE 179 : 101 CONTINUE 180 : IF (NFAC4.EQ.0) GOTO 103 181 : DO 104 I=1,NFAC4 182 : NTFAC(I+NFAC3)=IFAC4(1,I)+IFAC4(2,I)+IFAC4(3,I)+IFAC4(4,I) 183 : KFAK(I+NFAC3)=I 184 : 104 CONTINUE 185 : 103 CONTINUE 186 : IF (NFAC6.EQ.0) GOTO 105 187 : DO 106 I=1,NFAC6 188 : NTFAC(I+NFAC3+NFAC4)=IFAC6(1,I)+IFAC6(2,I)+IFAC6(3,I) 189 : # +IFAC6(4,I)+IFAC6(5,I)+IFAC6(6,I) 190 : KFAK(I+NFAC3+NFAC4)=I 191 : 106 CONTINUE 192 : 105 CONTINUE 193 : IF (NFAC8.EQ.0) GOTO 107 194 : DO 108 I=1,NFAC8 195 : NTFAC(I+NFAC3+NFAC4+NFAC6)=IFAC8(1,I)+IFAC8(2,I)+IFAC8(3,I) 196 : # +IFAC8(4,I)+IFAC8(5,I)+IFAC8(6,I)+IFAC8(7,I)+IFAC8(8,I) 197 : KFAK(I+NFAC3+NFAC4+NFAC6)=I 198 : 108 CONTINUE 199 : 107 CONTINUE 200 : C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT NTFAC 201 : SEGINI NAUX 202 : DO 300 ITYP=1,4 203 : GOTO (301,302,303,304),ITYP 204 : 301 CONTINUE 205 : IF (NFAC3.LE.1) GOTO 300 206 : NAUX(1)=1 207 : NAUX(2)=NFAC3 208 : GOTO 310 209 : 302 CONTINUE 210 : IF (NFAC4.LE.1) GOTO 300 211 : NAUX(1)=NFAC3+1 212 : NAUX(2)=NFAC3+NFAC4 213 : GOTO 310 214 : 303 CONTINUE 215 : IF (NFAC6.LE.1) GOTO 300 216 : NAUX(1)=NFAC3+NFAC4+1 217 : NAUX(2)=NFAC3+NFAC4+NFAC6 218 : GOTO 310 219 : 304 CONTINUE 220 : IF (NFAC8.LE.1) GOTO 300 221 : NAUX(1)=NFAC3+NFAC4+NFAC6+1 222 : NAUX(2)=NFAC 223 : GOTO 310 224 : 310 CONTINUE 225 : IZ=2 226 : 208 IZ=IZ-1 227 : IF (IZ.LE.0) GOTO 209 228 : IPB=NAUX(IZ*2-1) 229 : IPH=NAUX(IZ*2) 230 : IF(IPB.GE.IPH) GOTO 208 231 : JPB=IPB-1 232 : JPH=IPH+1 233 : C CALCUL DU PIVOT 234 : NPV=0 235 : * DO 207 J=IPB,IPH 236 : * NPV=NPV+NTFAC(J) 237 : *207 CONTINUE 238 : * NPV=NPV/(IPH-IPB+1) 239 : NPV=(NTFAC(IPB)+NTFAC(IPH))/2 240 : 242 JPB=JPB+1 241 : IF (JPH.EQ.JPB) GOTO 245 242 : IF (NTFAC(JPB).LE.NPV) GOTO 243 243 : GOTO 242 244 : 243 JPH=JPH-1 245 : IF (JPH.EQ.JPB) GOTO 245 246 : IF (NTFAC(JPH).GE.NPV) GOTO 244 247 : GOTO 243 248 : 244 IAUX=KFAK(JPB) 249 : KFAK(JPB)=KFAK(JPH) 250 : KFAK(JPH)=IAUX 251 : NTAUX=NTFAC(JPB) 252 : NTFAC(JPB)=NTFAC(JPH) 253 : NTFAC(JPH)=NTAUX 254 : GOTO 242 255 : 245 IF (JPB.GE.IPB) GOTO 247 256 : JPB=JPB+1 257 : JPH=JPH+2 258 : GOTO 248 259 : 247 IF (JPH.LE.IPH) GOTO 249 260 : JPB=JPB-2 261 : JPH=JPH-1 262 : GOTO 248 263 : 249 IF (NTFAC(JPB).LE.NPV) GOTO 250 264 : IF (JPH.EQ.IPH) GOTO 251 265 : 252 JPH=JPH+1 266 : GOTO 248 267 : 250 IF (JPB.EQ.IPB) GOTO 252 268 : 251 JPB=JPB-1 269 : 248 IF (JPB.EQ.IPB) GOTO 253 270 : NAUX(2*IZ)=JPB 271 : IZ=IZ+1 272 : 253 IF (JPH.EQ.IPH) GOTO 208 273 : NAUX(2*IZ)=IPH 274 : NAUX(2*IZ-1)=JPH 275 : IZ=IZ+1 276 : GOTO 208 277 : 209 CONTINUE 278 : 300 CONTINUE 279 : 280 : C ====================================================================== 281 : C LES FACES SONT CLASSEES DANS KFAK IL FAUT ELIMINER LES FACES EN DOUBL 282 : C ELLES SONT PAR TYPE LES UNES DERRIERES LES AUTRES LES PLUS HAUTES 283 : C DEVANT 284 : IF (IIMPI.NE.0) WRITE (IOIMP,9111) (KFAK(I),NTFAC(I),I=1,NFAC) 285 : 9111 FORMAT(5(2X,2I6)) 286 : DO 400 ITYP=1,4 287 : GOTO (401,402,403,404),ITYP 288 : 401 IF (NFAC3.LE.1) GOTO 400 289 : IDEB=1 290 : IFIN=NFAC3 291 : GOTO 410 292 : 402 IF (NFAC4.LE.1) GOTO 400 293 : IDEB=NFAC3+1 294 : IFIN=NFAC3+NFAC4 295 : GOTO 410 296 : 403 IF (NFAC6.LE.1) GOTO 400 297 : IDEB=NFAC3+NFAC4+1 298 : IFIN=NFAC3+NFAC4+NFAC6 299 : GOTO 410 300 : 404 IF (NFAC8.LE.1) GOTO 400 301 : IDEB=NFAC3+NFAC4+NFAC6+1 302 : IFIN=NFAC 303 : GOTO 410 304 : 410 CONTINUE 305 : IFINM=IFIN-1 306 : DO 450 I1=IDEB,IFINM 307 : NTI1=NTFAC(I1) 308 : IF (NTI1.EQ.0) GOTO 450 309 : IDEB1=I1+1 310 : DO 460 I2=IDEB1,IFIN 311 : NTI2=NTFAC(I2) 312 : IF (NTI2.EQ.0) GOTO 460 313 : IF (NTI2.NE.NTI1) GOTO 450 314 : IR1=KFAK(I1) 315 : IR2=KFAK(I2) 316 : GOTO (470,480,490,500),ITYP 317 : 470 CONTINUE 318 : DO 471 J1=1,3 319 : INU=IFAC3(J1,IR1) 320 : DO 472 J2=1,3 321 : IF (INU.EQ.IFAC3(J2,IR2)) GOTO 471 322 : 472 CONTINUE 323 : GOTO 520 324 : 471 CONTINUE 325 : GOTO 510 326 : 480 CONTINUE 327 : DO 481 J1=1,4 328 : INU=IFAC4(J1,IR1) 329 : DO 482 J2=1,4 330 : IF (INU.EQ.IFAC4(J2,IR2)) GOTO 481 331 : 482 CONTINUE 332 : GOTO 520 333 : 481 CONTINUE 334 : GOTO 510 335 : 490 CONTINUE 336 : DO 491 J1=1,6 337 : INU=IFAC6(J1,IR1) 338 : DO 492 J2=1,6 339 : IF (INU.EQ.IFAC6(J2,IR2)) GOTO 491 340 : 492 CONTINUE 341 : GOTO 520 342 : 491 CONTINUE 343 : GOTO 510 344 : 500 CONTINUE 345 : DO 501 J1=1,8 346 : INU=IFAC8(J1,IR1) 347 : DO 502 J2=1,8 348 : IF (INU.EQ.IFAC8(J2,IR2)) GOTO 501 349 : 502 CONTINUE 350 : GOTO 520 351 : 501 CONTINUE 352 : GOTO 510 353 : 520 CONTINUE 354 : GOTO 460 355 : 510 CONTINUE 356 : C DEUX FACES EGALES ON LES SUPPRIMENT 357 : NTFAC(I1)=0 358 : NTFAC(I2)=0 359 : GOTO 450 360 : 460 CONTINUE 361 : 450 CONTINUE 362 : 400 CONTINUE 363 : IPT1=0 364 : IPT2=0 365 : IPT3=0 366 : IPT4=0 367 : NBSOUS=0 368 : NBREF=0 369 : NBSOU2=0 370 : DO 600 ITY=1,4 371 : GOTO (610,620,630,640),ITY 372 : 610 CONTINUE 373 : IF (NFAC3.EQ.0) GOTO 600 374 : IDEB=1 375 : IFIN=NFAC3 376 : NBELEM=0 377 : DO 611 I=IDEB,IFIN 378 : IF (NTFAC(I).NE.0) NBELEM=NBELEM+1 379 : 611 CONTINUE 380 : IF (NBELEM.EQ.0) GOTO 600 381 : NBSOU2=NBSOU2+1 382 : NBNN=3 383 : SEGINI IPT1 384 : IPT1.ITYPEL=4 385 : JAUX=0 386 : DO 612 J=IDEB,IFIN 387 : IF (NTFAC(J).EQ.0) GOTO 612 388 : JAUX=JAUX+1 389 : IPT1.ICOLOR(JAUX)=IFAC3(4,KFAK(J)) 390 : DO 613 I=1,NBNN 391 : IPT1.NUM(I,JAUX)=IFAC3(I,KFAK(J)) 392 : 613 CONTINUE 393 : 612 CONTINUE 394 : SEGDES IPT1 395 : GOTO 600 396 : 620 CONTINUE 397 : IF (NFAC4.EQ.0) GOTO 600 398 : IDEB=NFAC3+1 399 : IFIN=NFAC3+NFAC4 400 : NBELEM=0 401 : DO 621 I=IDEB,IFIN 402 : IF (NTFAC(I).NE.0) NBELEM=NBELEM+1 403 : 621 CONTINUE 404 : IF (NBELEM.EQ.0) GOTO 600 405 : NBSOU2=NBSOU2+1 406 : NBNN=4 407 : SEGINI IPT2 408 : IPT2.ITYPEL=8 409 : JAUX=0 410 : DO 622 J=IDEB,IFIN 411 : IF (NTFAC(J).EQ.0) GOTO 622 412 : JAUX=JAUX+1 413 : IPT2.ICOLOR(JAUX)=IFAC4(5,KFAK(J)) 414 : DO 623 I=1,NBNN 415 : IPT2.NUM(I,JAUX)=IFAC4(I,KFAK(J)) 416 : 623 CONTINUE 417 : 622 CONTINUE 418 : SEGDES IPT2 419 : GOTO 600 420 : 630 CONTINUE 421 : IF (NFAC6.EQ.0) GOTO 600 422 : IDEB=NFAC3+NFAC4+1 423 : IFIN=NFAC3+NFAC4+NFAC6 424 : NBELEM=0 425 : DO 631 I=IDEB,IFIN 426 : IF (NTFAC(I).NE.0) NBELEM=NBELEM+1 427 : 631 CONTINUE 428 : IF (NBELEM.EQ.0) GOTO 600 429 : NBSOU2=NBSOU2+1 430 : NBNN=6 431 : SEGINI IPT3 432 : IPT3.ITYPEL=6 433 : JAUX=0 434 : DO 632 J=IDEB,IFIN 435 : IF (NTFAC(J).EQ.0) GOTO 632 436 : JAUX=JAUX+1 437 : IPT3.ICOLOR(JAUX)=IFAC6(7,KFAK(J)) 438 : DO 633 I=1,NBNN 439 : IPT3.NUM(I,JAUX)=IFAC6(I,KFAK(J)) 440 : 633 CONTINUE 441 : 632 CONTINUE 442 : SEGDES IPT3 443 : GOTO 600 444 : 640 CONTINUE 445 : IF (NFAC8.EQ.0) GOTO 600 446 : IDEB=NFAC3+NFAC4+NFAC6+1 447 : IFIN=NFAC 448 : NBELEM=0 449 : DO 641 I=IDEB,IFIN 450 : IF (NTFAC(I).NE.0) NBELEM=NBELEM+1 451 : 641 CONTINUE 452 : IF (NBELEM.EQ.0) GOTO 600 453 : NBSOU2=NBSOU2+1 454 : NBNN=8 455 : SEGINI IPT4 456 : IPT4.ITYPEL=10 457 : JAUX=0 458 : DO 642 J=IDEB,IFIN 459 : IF (NTFAC(J).EQ.0) GOTO 642 460 : JAUX=JAUX+1 461 : IPT4.ICOLOR(JAUX)=IFAC8(9,KFAK(J)) 462 : DO 643 I=1,NBNN 463 : IPT4.NUM(I,JAUX)=IFAC8(I,KFAK(J)) 464 : 643 CONTINUE 465 : 642 CONTINUE 466 : SEGDES IPT4 467 : GOTO 600 468 : 600 CONTINUE 469 : 470 : * on rajoute les points et les segments qui pouvaient etre dans le 471 : * maillage initial 472 : ipt5=0 473 : segact meleme 474 : ipt6=meleme 475 : do 710 io=1,max(1,lisous(/1)) 476 : if (lisous(/1).ne.0) ipt6=lisous(io) 477 : segact ipt6 478 : if (ipt6.itypel.le.3) then 479 : nbsou2=nbsou2+1 480 : ipt5=ipt6 481 : endif 482 : segdes ipt6 483 : 710 continue 484 : segdes meleme 484 : IF (NBSOU2.EQ.0.AND.NTPOL.EQ.0) CALL ERREUR(26) 485 : IF (NBSOU2.NE.1.OR.NTPOL.GE.0) GOTO 700 485 : CALL ECROBJ('MAILLAGE',IPT1+IPT2+IPT3+IPT4+ipt5) 486 : SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX 487 : RETURN 488 : 700 CONTINUE 489 : NBREF=0 490 : NBSOUS=NBSOU2+NTPOL 491 : NBNN=0 492 : NBELEM=0 493 : SEGINI IPT5 494 : I=0 495 : IF (IPT1.EQ.0) GOTO 701 496 : I=I+1 497 : IPT5.LISOUS(I)=IPT1 498 : 701 CONTINUE 499 : IF (IPT2.EQ.0) GOTO 702 500 : I=I+1 501 : IPT5.LISOUS(I)=IPT2 502 : 702 CONTINUE 503 : IF (IPT3.EQ.0) GOTO 703 504 : I=I+1 505 : IPT5.LISOUS(I)=IPT3 506 : 703 CONTINUE 507 : IF (IPT4.EQ.0) GOTO 704 508 : I=I+1 509 : IPT5.LISOUS(I)=IPT4 510 : 704 CONTINUE 511 : segact meleme 512 : ipt1=meleme 513 : do 711 io=1,max(1,lisous(/1)) 514 : if (lisous(/1).ne.0) ipt1=lisous(io) 515 : segact ipt1 516 : if (ipt1.itypel.le.3) then 517 : I=I+1 518 : IPT5.LISOUS(I)=IPT1 519 : endif 520 : segdes ipt1 521 : 711 continue 522 : DO 720, IO = 1, NTPOL 523 : I = I+1 524 : IPT5.LISOUS(I)=IPPOL(IO) 525 : 720 CONTINUE 526 : if (ipt5.lisous(/1).eq.1) then 527 : ipt6=ipt5 528 : ipt5=ipt6.lisous(1) 529 : segsup ipt6 530 : endif 531 : segdes meleme 532 : SEGDES IPT5 532 : CALL ECROBJ('MAILLAGE',IPT5) 533 : SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NTFAC,KFAK,NAUX,IPPOL 534 : RETURN 535 : END 536 : 537 : 538 : 539 : 540 : 541 : 542 : 543 : 544 : 545 : 546 : 547 : 548 :
© Cast3M 2003 - All rights reserved.
Disclaimer