1 : C FACED SOURCE CHAT 07/10/29 21:19:26 5940 2 : C TRACE D'UN OBJET PAR FACE EN COMMENCANT PAR CELLES DE DERRIERE 3 : C 4 : C imod=0 trace en couleur d'effacement 5 : C imod=1 trace en couleir normale 6 : C 7 : SUBROUTINE FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,imod) 8 : IMPLICIT INTEGER(I-N) 9 : -INC CCOPTIO 10 : -INC SMELEME 11 : -INC CCGEOME 12 : -INC CCREEL 13 : C+PP DEGRADE OU NON 14 : LOGICAL lndegr 15 : C+PP 16 : SEGMENT XPROJ(3,1) 17 : SEGMENT ICPR(1) 18 : SEGMENT IVU(ITE) 19 : SEGMENT MCOUP(0) 20 : SEGMENT KON(2,NBCON,NMAX) 21 : SEGMENT IFAC3(5,NFAC3) 22 : SEGMENT IFAC4(6,NFAC4) 23 : SEGMENT IFAC6(8,NFAC6) 24 : SEGMENT IFAC8(10,NFAC8) 25 : SEGMENT IFACP(16,NFACP) 26 : SEGMENT NSOMP(NFACP) 27 : SEGMENT IFACOL(NFAC) 28 : SEGMENT TFAC(NFAC) 29 : SEGMENT KFAK(NFAC) 30 : SEGMENT NAUX(NFAC) 31 : DIMENSION XTR(8),YTR(8),ZTR(8),NPTR(8) 32 : SEGACT MELEME 33 : MELSAU=MELEME 34 : IPT1=MELEME 35 : * IF (MCOUP.NE.0) THEN 36 : * NBNN=0 37 : * NBELEM=0 38 : * NBREF=0 39 : * NBSOUS=LISOUS(/1)-1 40 : * SEGINI IPT1 41 : * DO 5 I=1,NBSOUS 42 : * IPT1.LISOUS(I)=LISOUS(I) 43 : * 5 CONTINUE 44 : * ISCOUP=LISOUS(NBSOUS+1) 45 : * ENDIF 45 : * call ecmail(ipt1,0) 45 : CALL ECROBJ('MAILLAGE',IPT1) 45 : CALL ENVELO 46 : * IF (MCOUP.NE.0) SEGSUP IPT1 46 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 47 : IF (IERR.NE.0) RETURN 48 : SEGACT MELEME 49 : * IF (MCOUP.NE.0) THEN 50 : * IF (LISOUS(/1).NE.0) THEN 51 : * NBSOUS=LISOUS(/1)+1 52 : * SEGADJ MELEME 53 : * LISOUS(NBSOUS)=ISCOUP 54 : * ELSE 55 : * NBSOUS=2 56 : * SEGINI IPT1 57 : * IPT1.LISOUS(1)=MELEME 58 : * IPT1.LISOUS(2)=ISCOUP 59 : * MELEME=IPT1 60 : * ENDIF 61 : * ENDIF 62 : SEGACT XPROJ,ICPR 63 : SEGACT KON*MOD 64 : NBCON=KON(/2) 65 : NBCONR=NBCON-1 66 : NBPOIN=XPROJ(/2) 67 : TMIN=xsgran 68 : TMAX=-xsgran 69 : DO 1 I=1,NBPOIN 70 : TMIN=MIN(TMIN,XPROJ(3,I)) 71 : TMAX=MAX(TMAX,XPROJ(3,I)) 72 : 1 CONTINUE 73 : TDIST=TMAX-TMIN 74 : NFAC3=0 75 : NFAC4=0 76 : NFAC6=0 77 : NFAC8=0 78 : NFACP=0 79 : IPT1=MELEME 80 : SEGACT MELEME 81 : DO 10 IOB=1,MAX(1,LISOUS(/1)) 82 : IF (LISOUS(/1).NE.0) THEN 83 : IPT1=LISOUS(IOB) 84 : SEGACT IPT1 85 : ENDIF 86 : NBELEM=IPT1.NUM(/2) 87 : ILTEL=LTEL(1,IPT1.ITYPEL) 88 : IF (ILTEL.EQ.0) GOTO 12 89 : ILTAD=LTEL(2,IPT1.ITYPEL) 90 : DO 13 IF=1,ILTEL 91 : IFT=LDEL(1,ILTAD+IF-1) 92 : GOTO (21,22,23,24,25,26),IFT 93 : 21 NFAC3=NFAC3+NBELEM 94 : GOTO 30 95 : 22 NFAC4=NFAC4+NBELEM 96 : GOTO 30 97 : 23 NFAC6=NFAC6+NBELEM 98 : GOTO 30 99 : 24 NFAC8=NFAC8+NBELEM 100 : GOTO 30 101 : 25 GOTO 30 102 : 26 NFACP=NFACP+NBELEM 103 : GOTO 30 104 : 30 CONTINUE 105 : 13 CONTINUE 106 : 12 CONTINUE 107 : 10 CONTINUE 108 : SEGINI IFAC3,IFAC4,IFAC6,IFAC8,IFACP,NSOMP 109 : NFAC3=0 110 : NFAC4=0 111 : NFAC6=0 112 : NFAC8=0 113 : NFACP=0 114 : ICOUPE=0 115 : DO 50 IOB=1,MAX(1,LISOUS(/1)) 116 : IF (LISOUS(/1).NE.0) THEN 117 : IPT1=LISOUS(IOB) 118 : ICOUPE=0 119 : IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1 120 : ENDIF 121 : NBELEM=IPT1.NUM(/2) 122 : ILTEL=LTEL(1,IPT1.ITYPEL) 123 : IF (ILTEL.EQ.0) GOTO 52 124 : ILTAD=LTEL(2,IPT1.ITYPEL) 125 : DO 60 IF=1,ILTEL 126 : ITYP=LDEL(1,ILTAD+IF-1) 127 : IAD=LDEL(2,ILTAD+IF-1) 128 : DO 70 IEL=1,NBELEM 129 : GOTO (61,62,63,64,67,66),ITYP 130 : 61 NFAC3=NFAC3+1 131 : IFAC3(1,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD),IEL)) 132 : IFAC3(2,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL)) 133 : IFAC3(3,NFAC3)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL)) 134 : IFAC3(4,NFAC3)=IPT1.ICOLOR(IEL) 135 : IFAC3(5,NFAC3)=0 136 : IF (IVU(IFAC3(1,NFAC3)).EQ.1.AND.IVU(IFAC3(2,NFAC3)).EQ.1 137 : $ .AND.IVU(IFAC3(3,NFAC3)).EQ.1) IFAC3(5,NFAC3)=1 138 : IF (ICOUPE.EQ.1) THEN 139 : IF (MCOUP(IEL)/8.EQ.1) IFAC3(5,NFAC3)=2 140 : IF (MCOUP(IEL)/16.EQ.1) IFAC3(5,NFAC3)=3 141 : ENDIF 142 : GOTO 67 143 : 62 NFAC4=NFAC4+1 144 : IFAC4(1,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD),IEL)) 145 : IFAC4(2,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL)) 146 : IFAC4(3,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL)) 147 : IFAC4(4,NFAC4)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL)) 148 : IFAC4(5,NFAC4)=IPT1.ICOLOR(IEL) 149 : IFAC4(6,NFAC4)=0 150 : IF (IVU(IFAC4(1,NFAC4)).EQ.1.AND.IVU(IFAC4(2,NFAC4)).EQ.1 151 : $ .AND.IVU(IFAC4(3,NFAC4)).EQ.1.AND.IVU(IFAC4(4,NFAC4) 152 : $ ).EQ.1)IFAC4(6,NFAC4)=1 153 : GOTO 67 154 : 63 NFAC6=NFAC6+1 155 : IFAC6(1,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD) ,IEL)) 156 : IFAC6(2,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL)) 157 : IFAC6(3,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL)) 158 : IFAC6(4,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL)) 159 : IFAC6(5,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+4),IEL)) 160 : IFAC6(6,NFAC6)=ICPR(IPT1.NUM(LFAC(IAD+5),IEL)) 161 : IFAC6(7,NFAC6)=IPT1.ICOLOR(IEL) 162 : IFAC6(8,NFAC6)=0 163 : IF (IVU(IFAC6(1,NFAC6)).EQ.1.AND.IVU(IFAC6(2,NFAC6)).EQ.1 164 : $ .AND.IVU(IFAC6(3,NFAC6)).EQ.1.AND.IVU(IFAC6(4,NFAC6) 165 : $ ).EQ.1.AND.IVU(IFAC6(5,NFAC6)).EQ.1.AND.IVU(IFAC6(6 166 : $ ,NFAC6)).EQ.1)IFAC6(8,NFAC6)=1 167 : GOTO 67 168 : 64 CONTINUE 169 : NFAC8=NFAC8+1 170 : IFAC8(1,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD) ,IEL)) 171 : IFAC8(2,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+1),IEL)) 172 : IFAC8(3,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+2),IEL)) 173 : IFAC8(4,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+3),IEL)) 174 : IFAC8(5,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+4),IEL)) 175 : IFAC8(6,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+5),IEL)) 176 : IFAC8(7,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+6),IEL)) 177 : IFAC8(8,NFAC8)=ICPR(IPT1.NUM(LFAC(IAD+7),IEL)) 178 : IFAC8(9,NFAC8)=IPT1.ICOLOR(IEL) 179 : IFAC8(10,NFAC8)=0 180 : IF (IVU(IFAC8(1,NFAC8)).EQ.1.AND.IVU(IFAC8(2,NFAC8)).EQ.1 181 : $ .AND.IVU(IFAC8(3,NFAC8)).EQ.1.AND.IVU(IFAC8(4,NFAC8) 182 : $ ).EQ.1.AND.IVU(IFAC8(5,NFAC8)).EQ.1.AND.IVU(IFAC8(6 183 : $ ,NFAC8)).EQ.1.AND.IVU(IFAC8(7,NFAC8)).EQ.1.AND 184 : $ .IVU(IFAC8(8,NFAC8)).EQ.1)IFAC8(10,NFAC8)=1 185 : GOTO 67 186 : 66 NFACP=NFACP+1 187 : IFACP(16,NFACP)=1 188 : IFACP(15,NFACP)=IPT1.ICOLOR(IEL) 189 : NBNN=IPT1.NUM(/1) 190 : NSOMP(NFACP)= NBNN 191 : DO 660, IDC = 1, NBNN 192 : IFACP(IDC,NFACP)=ICPR(IPT1.NUM(LFAC(IAD+IDC-1),IEL)) 193 : IF (IVU(IFACP(IDC,NFACP)).NE.1) IFACP(16,NFACP)=0 194 : 660 CONTINUE 195 : GOTO 67 196 : 67 CONTINUE 197 : 70 CONTINUE 198 : 60 CONTINUE 199 : 52 CONTINUE 200 : IF (LISOUS(/1).NE.0) SEGDES IPT1 201 : 50 CONTINUE 202 : SEGDES MELEME 203 : C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES 204 : C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON 205 : NFAC=NFAC3+NFAC4+NFAC6+NFAC8+NFACP 206 : SEGINI TFAC,KFAK,IFACOL 207 : IF (NFAC3.EQ.0) GOTO 101 208 : DO 102 I=1,NFAC3 209 : TFAC(I)=(XPROJ(3,IFAC3(1,I))+XPROJ(3,IFAC3(2,I)) 210 : # + XPROJ(3,IFAC3(3,I)))/3. 211 : IF (IFAC3(5,I).EQ.1) TFAC(I)=TFAC(I)-TDIST 212 : IF (IFAC3(5,I).EQ.2) TFAC(I)=TFAC(I)-2*TDIST 213 : IFACOL(I)=IFAC3(4,I) 214 : KFAK(I)=I 215 : IF (IFAC3(5,I).EQ.3) KFAK(I)=0 216 : 102 CONTINUE 217 : 101 CONTINUE 218 : IF (NFAC4.EQ.0) GOTO 103 219 : DO 104 I=1,NFAC4 220 : TFAC(I+NFAC3)=(XPROJ(3,IFAC4(1,I))+XPROJ(3,IFAC4(2,I)) 221 : # + XPROJ(3,IFAC4(3,I))+XPROJ(3,IFAC4(4,I)))/4. 222 : IF (IFAC4(6,I).EQ.1) TFAC(I+NFAC3)=TFAC(I+NFAC3)-TDIST 223 : IFACOL(I+NFAC3)=IFAC4(5,I) 224 : KFAK(I+NFAC3)=I+NFAC 225 : 104 CONTINUE 226 : 103 CONTINUE 227 : IF (NFAC6.EQ.0) GOTO 105 228 : DO 106 I=1,NFAC6 229 : TFAC(I+NFAC3+NFAC4)=(XPROJ(3,IFAC6(1,I))+XPROJ(3,IFAC6(2,I)) 230 : # + XPROJ(3,IFAC6(3,I))+XPROJ(3,IFAC6(4,I)) 231 : # + XPROJ(3,IFAC6(5,I))+XPROJ(3,IFAC6(6,I)))/6. 232 : IF (IFAC6(8,I).EQ.1) TFAC(I+NFAC3+NFAC4)=TFAC(I+NFAC3+NFAC4) 233 : # -TDIST 234 : IFACOL(I+NFAC3+NFAC4)=IFAC6(7,I) 235 : KFAK(I+NFAC3+NFAC4)=I+2*NFAC 236 : 106 CONTINUE 237 : 105 CONTINUE 238 : IF (NFAC8.EQ.0) GOTO 107 239 : DO 108 I=1,NFAC8 240 : TFAC(I+NFAC3+NFAC4+NFAC6)=(XPROJ(3,IFAC8(1,I)) 241 : # +XPROJ(3,IFAC8(2,I))+XPROJ(3,IFAC8(3,I))+XPROJ(3,IFAC8(4,I 242 : $ ))+XPROJ(3,IFAC8(5,I))+XPROJ(3,IFAC8(6,I))+XPROJ(3,IFAC8(7 243 : $ ,I))+XPROJ(3,IFAC8(8,I)))/8. 244 : IF (IFAC8(10,I).EQ.1) TFAC(I+NFAC3+NFAC4+NFAC6)= 245 : # TFAC(I+NFAC3+NFAC4+NFAC6)-TDIST 246 : IFACOL(I+NFAC3+NFAC4+NFAC6)=IFAC8(9,I) 247 : KFAK(I+NFAC3+NFAC4+NFAC6)=I+3*NFAC 248 : 108 CONTINUE 249 : 107 CONTINUE 250 : IF (NFACP.EQ.0) GOTO 110 251 : DO 109 I=1,NFACP 252 : XXXX = 0. 253 : DO 120 J=1, NSOMP(I) 254 : XXXX = XXXX + XPROJ(3,ICPR(IFACP(J,I))) 255 : 120 CONTINUE 256 : TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)= XXXX/NSOMP(I) 257 : IF (IFACP(16,I).EQ.1) TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)= 258 : # TFAC(I+NFAC3+NFAC4+NFAC6+NFAC8)-TDIST 259 : IFACOL(I+NFAC3+NFAC4+NFAC6+NFAC8)=IFACP(15,I) 260 : KFAK(I+NFAC3+NFAC4+NFAC6+NFAC8)=I+4*NFAC 261 : 109 CONTINUE 262 : 110 CONTINUE 263 : C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC 264 : SEGINI NAUX 265 : IF (IDIM.EQ.2) GOTO 209 266 : NAUX(1)=1 267 : NAUX(2)=NFAC 268 : IZ=2 269 : 208 IZ=IZ-1 270 : IF (IZ.LE.0) GOTO 209 271 : IPB=NAUX(IZ*2-1) 272 : IPH=NAUX(IZ*2) 273 : IF(IPB.GE.IPH) GOTO 208 274 : JPB=IPB-1 275 : JPH=IPH+1 276 : C CALCUL DU PIVOT 277 : PV=0. 278 : * DO 207 J=IPB,IPH 279 : * PV=PV+TFAC(J) 280 : *207 CONTINUE 281 : * PV=PV/(IPH-IPB+1) 282 : PV=(TFAC(IPB)+TFAC(IPH))/2. 283 : 242 JPB=JPB+1 284 : IF (JPH.EQ.JPB) GOTO 245 285 : IF (TFAC(JPB).LT.PV) GOTO 243 286 : GOTO 242 287 : 243 JPH=JPH-1 288 : IF (JPH.EQ.JPB) GOTO 245 289 : IF (TFAC(JPH).GT.PV) GOTO 244 290 : GOTO 243 291 : 244 IAUX=KFAK(JPB) 292 : IAUXX=IFACOL(JPB) 293 : KFAK(JPB)=KFAK(JPH) 294 : IFACOL(JPB)=IFACOL(JPH) 295 : KFAK(JPH)=IAUX 296 : IFACOL(JPH)=IAUXX 297 : TAUX=TFAC(JPB) 298 : TFAC(JPB)=TFAC(JPH) 299 : TFAC(JPH)=TAUX 300 : GOTO 242 301 : 245 IF (JPB.GE.IPB) GOTO 247 302 : JPB=JPB+1 303 : JPH=JPH+2 304 : GOTO 248 305 : 247 IF (JPH.LE.IPH) GOTO 249 306 : JPB=JPB-2 307 : JPH=JPH-1 308 : GOTO 248 309 : 249 IF (TFAC(JPB).LE.PV) GOTO 250 310 : IF (JPH.EQ.IPH) GOTO 251 311 : 252 JPH=JPH+1 312 : GOTO 248 313 : 250 IF (JPB.EQ.IPB) GOTO 252 314 : 251 JPB=JPB-1 315 : 248 IF (JPB.EQ.IPB) GOTO 253 316 : NAUX(2*IZ)=JPB 317 : IZ=IZ+1 318 : 253 IF (JPH.EQ.IPH) GOTO 208 319 : NAUX(2*IZ)=IPH 320 : NAUX(2*IZ-1)=JPH 321 : IZ=IZ+1 322 : GOTO 208 323 : 209 CONTINUE 324 : C LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR 325 : C ENVELO . IL NE RESTE PLUS QU'A TRACER 326 : DO 300 I=1,NFAC 327 : IFF=KFAK(I) 328 : IF (IFF.EQ.0) GOTO 300 329 : IT=(IFF-1)/NFAC 330 : IF=IFF-IT*NFAC 331 : IT=IT+1 332 : IOK=0 333 : GOTO (310,320,330,340,350),IT 334 : 310 NP=3 335 : DO 311 IP=1,NP 336 : XTR(IP)=XPROJ(1,IFAC3(IP,IF)) 337 : YTR(IP)=XPROJ(2,IFAC3(IP,IF)) 338 : ZTR(IP)=XPROJ(3,IFAC3(IP,IF)) 339 : NPTR(IP)=IFAC3(IP,IF) 340 : IF (IVU(IFAC3(IP,IF)).EQ.1) IOK=1 341 : 311 CONTINUE 342 : GOTO 370 343 : 320 NP=4 344 : DO 321 IP=1,NP 345 : XTR(IP)=XPROJ(1,IFAC4(IP,IF)) 346 : YTR(IP)=XPROJ(2,IFAC4(IP,IF)) 347 : ZTR(IP)=XPROJ(3,IFAC4(IP,IF)) 348 : NPTR(IP)=IFAC4(IP,IF) 349 : IF (IVU(IFAC4(IP,IF)).EQ.1) IOK=1 350 : 321 CONTINUE 351 : GOTO 370 352 : 330 NP=6 353 : DO 331 IP=1,NP 354 : XTR(IP)=XPROJ(1,IFAC6(IP,IF)) 355 : YTR(IP)=XPROJ(2,IFAC6(IP,IF)) 356 : ZTR(IP)=XPROJ(3,IFAC6(IP,IF)) 357 : NPTR(IP)=IFAC6(IP,IF) 358 : IF (IVU(IFAC6(IP,IF)).EQ.1) IOK=1 359 : 331 CONTINUE 360 : GOTO 370 361 : 340 NP=8 362 : DO 341 IP=1,NP 363 : XTR(IP)=XPROJ(1,IFAC8(IP,IF)) 364 : YTR(IP)=XPROJ(2,IFAC8(IP,IF)) 365 : ZTR(IP)=XPROJ(3,IFAC8(IP,IF)) 366 : NPTR(IP)=IFAC8(IP,IF) 367 : IF (IVU(IFAC8(IP,IF)).EQ.1) IOK=1 368 : 341 CONTINUE 369 : GOTO 370 370 : 350 NP=NSOMP(IF) 371 : DO 351 IP=1,NP 372 : XTR(IP)=XPROJ(1,IFACP(IP,IF)) 373 : YTR(IP)=XPROJ(2,IFACP(IP,IF)) 374 : ZTR(IP)=XPROJ(3,IFACP(IP,IF)) 375 : NPTR(IP)=IFACP(IP,IF) 376 : IF (IVU(IFACP(IP,IF)).EQ.1) IOK=1 377 : 351 CONTINUE 378 : 370 CONTINUE 379 : IF (IOK.EQ.0) GOTO 300 380 : C DETERMINATION DE LA COULEUR D'APRES L'ORIENTATION DE LA NORMALE 381 : XN=0. 382 : YN=0. 383 : ZN=0. 384 : XDE=XTR(NP) 385 : YDE=YTR(NP) 386 : ZDE=ZTR(NP) 387 : XW1=XTR(1)-XDE 388 : YW1=YTR(1)-YDE 389 : ZW1=ZTR(1)-ZDE 390 : DO 900 I2=2,NP-1 391 : XW2=XTR(I2)-XDE 392 : YW2=YTR(I2)-YDE 393 : ZW2=ZTR(I2)-ZDE 394 : XN=XN+(YW1*ZW2-ZW1*YW2) 395 : YN=YN+(ZW1*XW2-XW1*ZW2) 396 : ZN=ZN+(XW1*YW2-YW1*XW2) 397 : XW1=XW2 398 : YW1=YW2 399 : ZW1=ZW2 400 : 900 CONTINUE 401 : DN=SQRT(XN**2+YN**2+ZN**2) 402 : IF (DN.EQ.0.) DN=1. 403 : ZN=ASIN(ABS(ZN/DN)) 404 : C+PP DEGRADE OU NON 405 : IF (lndegr) ZN=REAL(XPI/2.D0) 406 : C+PP 407 : IFACO=IFACOL(I) 408 : if (imod.eq.0) ifaco=8 408 : CALL TRFACE(NP,XTR,YTR,ZTR,ZN,IFACO,IEFF) 409 : if (imod.eq.0) ieff=0 410 : C SI IEFF <> 0 IL FAUT METTRE LES TRAITS EN EFFACEMENT 411 : N1=NPTR(NP) 412 : DO 450 IIP=1,NP 413 : N2=NPTR(IIP) 414 : NI=N1 415 : NJ=N2 416 : 459 CONTINUE 417 : 457 DO 454 K=1,NBCONR 418 : IF (KON(1,K,NI).NE.NJ) GOTO 454 419 : C 8 = EFFACEMENT 420 : KON(2,K,NI)=8 421 : IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I) 422 : GOTO 456 423 : 454 CONTINUE 424 : IF (KON(1,NBCON,NI).EQ.0) GOTO 456 425 : NI=KON(1,NBCON,NI) 426 : GOTO 457 427 : 456 CONTINUE 428 : NI=N2 429 : NJ=N1 430 : 469 CONTINUE 431 : 467 DO 464 K=1,NBCONR 432 : IF (KON(1,K,NI).NE.NJ) GOTO 464 433 : C 8 = EFFACEMENT 434 : KON(2,K,NI)=8 435 : IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I) 436 : GOTO 466 437 : 464 CONTINUE 438 : IF (KON(1,NBCON,NI).EQ.0) GOTO 466 439 : NI=KON(1,NBCON,NI) 440 : GOTO 467 441 : 466 CONTINUE 442 : N1=N2 443 : 450 CONTINUE 444 : 300 CONTINUE 445 : C 'EST FINI 446 : SEGACT MELEME 447 : IF (LISOUS(/1).NE.0) THEN 448 : NBSOUS=LISOUS(/1) 449 : * IF (MCOUP.NE.0) NBSOUS=NBSOUS-1 450 : DO 490 IO=1,NBSOUS 451 : IPT2=LISOUS(IO) 452 : segact ipt2 453 : if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) SEGSUP IPT2 454 : 490 CONTINUE 455 : ENDIF 456 : if (itypel.eq.0) SEGSUP MELEME 457 : MELEME=MELSAU 458 : SEGDES KON 459 : SEGSUP IFAC3,IFAC4,IFAC6,IFAC8,NAUX,TFAC,KFAK,IFACOL,IFACP,NSOMP 460 : RETURN 461 : END 462 : 463 : 464 : 465 : 466 : 467 : 468 : 469 : 470 : 471 : 472 : 473 : 474 : 475 : 476 : 477 : 478 : 479 : 480 : 481 :
© Cast3M 2003 - All rights reserved.
Disclaimer