1 : C PRTRAC SOURCE GOUNAND 13/10/21 21:15:24 7822 2 : SUBROUTINE PRTRAC 3 : *======================================================================= 4 : * 5 : * CE SOUS PROGRAMME GERE LES TRACES. 6 : * 7 : * IL COMMENCE PAR FABRIQUER L'ENSEMBLE DES SEGMENTS A TRACER EN 8 : * EXTRAYANT LES POINTS UTILES DE L'ENSEMBLE DES POINTS 9 : * 10 : * PUIS IL APPELE LA PROJECTION ET EFFECTUE LE TRACE. 11 : * 12 : * OPTIONS POSSIBLES 13 : * QUALIFIE = TRACE AVEC LES NOMS D'OBJETS 14 : * NOEUDS = TRACE AVEC LES NUMEROS REELS DE NOEU 15 : * ELEMENTS = TRACE AVEC LES NUMEROS D'ELEMENT PAR 16 : * OBJET ELEMENTAIRE 17 : * COULEUR = TRACE UNIQUEMENT LA COULEUR COURANTE 18 : * OU LA COULEUR CHOISIE 19 : * CACHE = TRACE EN "PARTIES VUES-CACHEES" 20 : * ECLATE = TRACE EN ECLATANT LES ELEMENTS 21 : * PEUT ETRE SUIVI PAR UN COEFFICIENT 22 : * FACE = TRACE EN REPRESENTATION PAR FACETTE 23 : * EXCLUT POUR LE MOMENT LES AUTRES OPTIONS 24 : * COUPE = TRACE EN EXCLUANT DE LA REPRESENTATION LA PARTIE 25 : * SITUE PLUS PRES DE L'OBSERVATEUR QU'UN PLAN DONNE 26 : * SECTION = TRACE DE L'INTERSECTION AVEC UN PLAN DONNE 27 : * CHAMP = AFFICHE LA VALEUR DU CHAMP AU POINT SUPPORT 28 : * 29 : *======================================================================= 30 : * 31 : * Modifications : 32 : * 33 : * NOEL 1984 Trace des DEFORMES 34 : * En ce cas lecture non d'une geometrie mais d'un objet DEFORME 35 : * La seule option permise est CACHE 36 : * 37 : * AOUT 1985 Trace d'ISOVALEUR 38 : * Trace les isovaleurs d'un objet de type CHAMPOINT uniquement 39 : * Par defaut on trace 7 isovaleurs 40 : * OPTION : Si prealablement on a cree un objet avec 41 : * l'operateur 'PROG', on peut tracer le nombre d'isovaleurs 42 : * que l'on desire (7 MAXI) 43 : * 44 : * MARS 1986 Introduction de l'option COUPE limitee a la coupe par 45 : * un plan en 3D uniquement 46 : * 47 : * AOUT 1986 Introduction du trace de vecteurs 48 : * 49 : * 1995 Option 'DIRE' et compagnie P.PEGON JRC-ISPRA 50 : * 51 : * FEV 1999 Augmentation des marges autour du dessin 52 : * 53 : * 09/2003 Modifications (temporaires ?) dans le cas IDIM=1. 54 : * 55 : * OCT. 2007 PM : 56 : * .Retournement axe des isovaleurs / amplitude deformee / 57 : * legende vecteurs, contraintes et fissures 58 : * .Couleur des segments marche avec nouvelles couleurs 59 : * .Du fait du passage a 16 couleurs et de la precision des entiers, 60 : * ajout d'une dimension a KON pour specifier le codage de la 61 : * couleur : 0 = une seule, codage normal (anciennement < 300) 62 : * 1 = Possiblement plusieurs, codage binaire par 63 : * puissance de 2 (anciennement > 300) 64 : * .Des nombres en dur lies au nb de couleurs et a l'indice du noir 65 : * passent en parametres 66 : * .Passage du nb de legendes max des vecteurs a 40 (au lieu de 8) 67 : * .Augmentation du nb de legendes de deformees a NDEFMX=40 68 : * auparavant limite en dur a 7 69 : * .Mauvaise identification des elements Navier-Stokes depuis l'ajout de 70 : * nouveaux elements 71 : * 72 : *======================================================================= 73 : * 74 : * REMARQUES : 75 : * 76 : * Limitation a NLEGMX du nombre de legendes de vecteurs 77 : * 78 : *======================================================================= 79 : * 80 : * VARIABLES : 81 : * 82 : * ICHL : tableau des numero de couleur a prendre pour les deformees 83 : * 84 : *======================================================================= 85 : IMPLICIT INTEGER(I-N) 86 : C IMPLICIT REAL*8 (A-H,O-Z) 87 : 88 : EXTERNAL LONG 89 : -INC CCREEL 90 : -INC CCOPTIO 91 : -INC CCGEOME 92 : -INC SMELEME 93 : -INC CCNOYAU 94 : -INC CCASSIS 95 : -INC SMDEFOR 96 : -INC SMCHPOI 97 : -INC SMVECTE 98 : -INC SMMODEL 99 : -INC SMCOORD 100 : -INC CCTRACE 101 : 102 : C Pointeur de sauvegarde du maillage en DIMEnsion 1 103 : POINTEUR ICOORSAV.MCOORD 104 : SEGMENT XCORD(IDIM,ITE) 105 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 106 : SEGMENT JCPR(XCOOR(/1)/(IDIM+1)) 107 : SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1)) 108 : SEGMENT IVU(ITE) 109 : SEGMENT NTSEG(LTSEGS) 110 : SEGMENT KON(3,NBCON,NMAX) 111 : SEGMENT XPROJ(3,ITE) 112 : SEGMENT XPRO2(3,ITE) 113 : SEGMENT KXPRO2(NVEC) 114 : SEGMENT KABEL(0) 115 : SEGMENT KABCOR(0) 116 : SEGMENT LABCO2(3,0) 117 : SEGMENT KABEL2(0) 118 : SEGMENT KABCO3(0) 119 : SEGMENT LABCO3(3,0) 120 : SEGMENT KABCO2(2,0) 121 : SEGMENT ICOR2(0) 122 : SEGMENT KABCPR(0) 123 : SEGMENT KABCP2(0) 124 : SEGMENT MCOUP(0) 125 : 126 : LOGICAL COUPE,ZDATE,ZCHAM,ZLEGI 127 : REAL DDEC,PDDEC,PYB 128 : CHARACTER TXTIT*72,TXISO*12,VALISO*12 129 : CHARACTER*72 TITRY,MONMES 130 : CHARACTER*8 TXT 131 : CHARACTER*7 FMTX 132 : CHARACTER*64 ABCDEF 133 : CHARACTER*12 ZONE 134 : CHARACTER*13 LEGEND(10),COMPCH(10) 135 : CHARACTER*10 TMPCAR 136 : *PM NBCOUL-1 au lieu de 8, et IPUIS2 137 : *PV NBCOUL pas connu a la compilation => valeur numerique 138 : INTEGER ICHC(0:15 ),ICHCS(0:15 ),ITEST(0:15 ), 139 : & IPUIS2(0:15 ) 140 : PARAMETER (NDEFMX=40) 141 : INTEGER ICHL(NDEFMX) 142 : C+PP (DIRE et FACB et FSDB) 143 : PARAMETER (ISOPT=20) 144 : CHARACTER*4 MSOPT(ISOPT),MOVE(6) 145 : DIMENSION diloc(3) 146 : C+PP 147 : DIMENSION XTR(40),YTR(40),ZTR(40) 148 : DIMENSION PX(4),PY(4) 149 : LOGICAL VALEUR,FENET,BLOCAG,INWDS,INWDS2,CROIX 150 : C probleme optimiseur sur rs6K 151 : SAVE NTSEG 152 : REAL VCHC,VAMPF 153 : REAL*8 XXX 154 : dimension cgrav(3),axez(3) 155 : DIMENSION VCHC(70) 156 : * pour les traces de legendes de vecteurs 157 : PARAMETER (NLEGMX=40) 158 : DIMENSION NVCOL(NLEGMX),VAMPF(NLEGMX) 159 : CHARACTER*4 NVLEG(3,NLEGMX) 160 : C+PP + option DIRE et divers FACE 161 : LOGICAL ldire, lndegr, lblanc 162 : * BERTIN: ajout de variable 163 : REAL XB,YB,ZB,XE,YE,ZE,OEBA,XM,YM,ZM,BARY(3),XU,YU,ZU 164 : REAL A,B,C,YHAUT,XHAUT 165 : INTEGER ZCOM,AB,BA,I,K,ISOVU 166 : CHARACTER*72 BUFFER,TIME 167 : CHARACTER*10 VALCH 168 : CHARACTER*4 MODEC(3) 169 : 170 : C+PP 171 : DATA ABCDEF( 1:32)/'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdef'/ 172 : DATA ABCDEF(33:64)/'ghijklmnopqrstuvwxyz0123456789&@'/ 173 : C PP + option DIRE et divers FACE 174 : DATA MSOPT/'QUAL','NOEU','ELEM','CACH','ECLA','COUL','FACE', 175 : * 'COUP','ANIM','OSCI','ARET','TITR','LEGE','NCLK','SECT', 176 : * 'DIRE','FACB','FSDB','DATE','CHAM'/ 177 : DATA MOVE/'SI11','SI22','SI33','FIS1','FIS2','FIS3'/ 178 : cbp espacement des legendes des isovaleur (-> nombre maxi NDEC=25 par defaut) 179 : DATA MODEC/'VING','DIX ','CINQ'/ 180 : 181 : *----------------------------------------------------------------------- 182 : C L'operateur TRACER ne marche pas en l'etat pour le cas IDIM=1. 183 : C Astuce : au debut de l'appel a PRTRAC, on recopie le SEGMENT MCOORD 184 : C a 1 DIMENSION dans un segment MCOORD a 2 DIMENSIONs. On effectue 185 : C l'operation inverse lors de la sortie de PRTRAC (GOTO 8900). 186 : C Utiliser IDIMSAV pour savoir si dimension = 1 (0 sinon). 187 : *----------------------------------------------------------------------- 188 : IF (IDIM.EQ.1) THEN 189 : ICOORSAV=MCOORD 190 : IDIMSAV=IDIM 191 : NBPTS=XCOOR(/1)/(IDIMSAV+1) 192 : IDIM=IDIM+1 193 : SEGINI MCOORD 194 : j=IDIM+1 195 : k=IDIMSAV+1 196 : DO i=1,NBPTS 197 : XCOOR((i-1)*j+1)=ICOORSAV.XCOOR((i-1)*k+1) 198 : XCOOR(i*j)=ICOORSAV.XCOOR(i*k) 199 : ENDDO 200 : ELSE 201 : IDIMSAV=0 202 : ENDIF 203 : 204 : *----------------------------------------------------------------------- 205 : * INITIALISATIONS 206 : *----------------------------------------------------------------------- 207 : ite=0 208 : mlreel=0 209 : LCOMP=0 210 : NCOMP=0 211 : MCARA=0 212 : MCAR1=0 213 : melemi=0 214 : melei2=0 215 : ampimp=amplit 216 : * POUR EVITER DES PROBLEMES UN DEFAUT SUR NCOUMA 217 : NCOUMA=7 218 : BLOCAG=.FALSE. 219 : CROIX =.FALSE. 220 : INWDS =.TRUE. 221 : INWDS2=.TRUE. 222 : ICHISO=0 223 : vchmin=xsgran 224 : vchmax=-xsgran 225 : ipv=0 226 : IPVV=0 227 : melsau=0 228 : mcham=0 229 : VCPCHA=0 230 : IANIM=0 231 : KON=0 232 : ISORT=0 233 : ICLE=0 234 : ITR=1 235 : IVU=0 236 : NTSEG=0 237 : XPROJ=0 238 : XPRO2=0 239 : KXPRO2=0 240 : IVEC=0 241 : NVECL=0 242 : NBCTS=0 243 : IRETO2=0 244 : KABCOR=0 245 : KABCO2=0 246 : KABCO3=0 247 : LABCO2=0 248 : LABCO3=0 249 : KABEL =0 250 : KABEL2=0 251 : KABCPR=0 252 : KABCP2=0 253 : ICOR2=0 254 : DIOCA2=REAL(DIOCAD) 255 : TITRY=TITREE 256 : TXTIT =' ' 257 : TXISO =' ' 258 : VALISO='VAL - ISO' 259 : KCLICK=1 260 : SEGACT MCOORD*MOD 261 : XPRO2=0 262 : MCOU2=0 263 : icoup1=0 264 : coupol=-1. 265 : MELEM2=0 266 : MDEFOR=0 267 : NDEF=0 268 : VALEUR=.FALSE. 269 : FENET=.TRUE. 270 : MCOUP=0 271 : NISO=0 272 : IMEL2=0 273 : IMEL3=0 274 : ZCOM=0 275 : ZDATE=.FALSE. 276 : ISOVU=-1 277 : ZCHAM=.FALSE. 278 : ZLEGI=.FALSE. 279 : VALCH=' ' 280 : XHAUT=0. 281 : YHAUT=0. 282 : C INIT DU TABLEAU COMPTEUR DE COULEUR 283 : * on ne compte pas le nb de fois que la couleur DEFA (i=0) apparait 284 : DO i=1,NBCOUL-1 285 : ICHC(i)=0 286 : ENDDO 287 : DO i=1,NDEFMX 288 : ICHL(i)=0 289 : ENDDO 290 : *PM precalcul des puissances de 2 : IPUIS2(IC)=2**(IC-1) 291 : IPUIS2(0)=0 292 : K2=1 293 : DO i=1,NBCOUL-1 294 : IPUIS2(i)=K2 295 : K2=K2*2 296 : ENDDO 297 : IICOL=IDCOUL 298 : IDEF=1 299 : IRESU=0 300 : IECLAT=0 301 : IQUALI=0 302 : INUMNO=0 303 : INUMEL=0 304 : ICACHE=0 305 : IFADES=0 306 : IDEFCO=0 307 : IDEFOR=0 308 : IDEFS=0 309 : KDEFOR=0 310 : ICOUP=0 311 : icoupd=0 312 : ISECT=0 313 : IARET=0 314 : C+PP + option DIRE et divers FACE 315 : ldire =.FALSE. 316 : lndegr=.FALSE. 317 : lblanc=.FALSE. 318 : C+PP 319 : 320 : *----------------------------------------------------------------------- 321 : * LECTURE DES PARAMETRES 322 : *----------------------------------------------------------------------- 323 : cBP ajout possibilite d'espacer + les legendes avec VING DIX ou CINQ... 323 : CALL LIRMOT(MODEC,3,NDEC2,0) 324 : C PP + option DIRE et divers FACE 324 : 4020 CALL LIRMOT(MSOPT,ISOPT,IR,0) 325 : IF (IR.EQ.0) GOTO 4000 326 : C PP + option DIRE (4016) et divers FACE (4017,4018) 327 : GOTO (4001,4002,4003,4004,4005,4006,4007,4008,4009,4010,4011, 328 : > 4012,4013,4014,4015,4016,4017,4018,4019,4021),IR 329 : 4001 IQUALI=1 330 : GOTO 4020 331 : 4002 INUMNO=1 332 : GOTO 4020 333 : 4003 INUMEL=1 334 : GOTO 4020 335 : 4004 ICACHE=1 336 : GOTO 4020 337 : 4005 IECLAT=1 338 : XXX=0.5D0 338 : CALL LIRREE(XXX,0,IRETOU) 339 : XECLAT=REAL(XXX) 340 : GOTO 4020 341 : 4006 IDEFCO=1 341 : CALL LIRMOT(NCOUL,NBCOUL,IICOL,0) 342 : IF (IICOL.EQ.0) IICOL=IDCOUL+1 343 : IICOL=IICOL-1 344 : GOTO 4020 345 : C+PP divers FACE 346 : 4017 lndegr=.TRUE. 347 : 4018 lblanc=.TRUE. 348 : C+PP 349 : 4007 IFADES=1 350 : ICACHE=1 351 : GOTO 4020 352 : 4008 ICOUP=1 353 : GOTO 4020 354 : 4009 IANIM=1 355 : GOTO 4020 356 : 4010 IANIM=2 357 : GOTO 4020 358 : 4011 IARET=1 359 : GOTO 4020 359 : 4012 CALL LIRCHA(TXTIT(1:72),0,IRETOU) 360 : IF (IRETOU.EQ.0) TXTIT=' ' 361 : GOTO 4020 361 : 4013 CALL LIRCHA(TXISO(1:12),0,IRETOU) 362 : IF (IRETOU.EQ.0) TXISO=' ' 363 : GOTO 4020 364 : 4014 KCLICK=0 365 : GOTO 4020 366 : 4015 ISECT=1 367 : ICOUP=1 368 : GOTO 4020 369 : C+PP + option DIRE (4016) 370 : 4016 ldire=.TRUE. 371 : IF (IDIM.NE.3) ldire=.FALSE. 372 : GOTO 4020 373 : 4019 ZDATE=.TRUE. 374 : GOTO 4020 375 : 4021 continue 376 : ZCHAM=.TRUE. 377 : GOTO 4020 378 : C+PP 379 : 380 : 4000 CONTINUE 381 : * MODIF POUR AUTORISER RIGIDITE A LA PLACE DE GEOMETRIE 381 : CALL LIROBJ('RIGIDITE',III,0,IRETOU) 382 : IF (IRETOU.EQ.1) THEN 382 : CALL ECRCHA('MAILLAGE') 382 : CALL ECROBJ('RIGIDITE',III) 382 : CALL EXTRAI 383 : ENDIF 384 : IF (IDIM.EQ.2.OR.IECLAT.EQ.1) THEN 385 : ICACHE=0 386 : ICOUP=0 387 : ENDIF 388 : 389 : * Lecture du point d'observation et des points de coupe 389 : IF (IDIM.EQ.3) CALL LIROBJ('POINT',IOEI,0,IRETOU) 390 : IF (ICOUP.EQ.1) THEN 390 : CALL LIROBJ('POINT',ICOUP1,1,IRETO) 390 : CALL LIROBJ('POINT',ICOUP2,1,IRETO) 391 : iob=0 392 : if (iretou.eq.0) iob=1 392 : CALL LIROBJ('POINT',ICOUP3,iob,IRETO) 393 : if (ireto.eq.0) then 394 : icoup3=ioei 395 : ioei=0 396 : endif 397 : IF (IERR.NE.0) GOTO 8900 398 : ENDIF 399 : 400 : C PP + option DIRE 401 : IF (ICOUP.EQ.1.AND.ldire.AND.IOEI.NE.0) THEN 402 : xno1=0. 403 : xno2=0. 404 : psca=0. 405 : do i=1,3 406 : cgrav(i)=REAL(xcoor((ICOUP1-1)*4+i)) 407 : diloc(i)=REAL(xcoor((ICOUP2-1)*4+i)) - cgrav(i) 408 : xno1=xno1+(cgrav(i)-REAL(xcoor((IOEI-1)*4+i)))**2 409 : xno2=xno2+ diloc(i)**2 410 : psca=psca+(cgrav(i)-REAL(xcoor((IOEI-1)*4+i)))*diloc(i) 411 : enddo 412 : xno1=SQRT(xno1*xno2) 413 : IF (xno1.LT.1.D-5) then 414 : * Tache impossible. Probablement donnees erronees 414 : CALL ERREUR(26) 415 : ELSE 416 : if (ABS(psca/xno1).GT.0.5D0) THEN 417 : * Tache impossible. Probablement donnees erronees 417 : CALL ERREUR(26) 418 : ENDIF 419 : ENDIF 420 : DO i=1,3 421 : diloc(i)=diloc(i)/SQRT(xno2) 422 : ENDDO 423 : ELSE 424 : do i=1,3 425 : cgrav(i)=0. 426 : diloc(i)=0. 427 : enddo 428 : ENDIF 429 : C PP 430 : * en l'absence d'oeil specifie, on en met un par defaut 431 : IF (IDIM.EQ.3) THEN 432 : IF (IOEI.NE.0) IOEIL=IOEI 433 : IF (IOEIL.EQ.0) THEN 434 : * il n'y a meme pas d'oeil par defaut 435 : NBPTS=XCOOR(/1)/4+1 436 : SEGADJ MCOORD 437 : IOEIL=NBPTS 438 : XCOOR((IOEIL-1)*4+1)= 1.0D6 439 : XCOOR((IOEIL-1)*4+2)=-1.2D6 440 : XCOOR((IOEIL-1)*4+3)= 0.9D6 441 : XCOOR((IOEIL-1)*4+4)= 1 442 : ENDIF 443 : ENDIF 444 : IF (IERR.NE.0) GOTO 8900 445 : IOEINI=IOEIL 446 : MVECTE=0 447 : MVECTS=MVECTE 447 : CALL LIROBJ('VECTEUR ',MVECTE,0,IRETO1) 448 : MVECTS=MVECTE 448 : IF (MVECTE.NE.0) CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 449 : IF (IERR.NE.0) GOTO 8900 450 : MDEFOR=0 450 : IF (MVECTE.EQ.0) CALL LIROBJ('DEFORME ',MDEFOR,0,IRETO2) 451 : IDEFOR=IRETO2 452 : IF (IDEFOR.EQ.1) THEN 453 : SEGACT MDEFOR 454 : IF(MDCHP(1).NE.0.OR.MDCHEL(1).NE.0) ICHISO=1 455 : ENDIF 456 : 457 : *----------------------------------------------------------------------- 458 : * RECHERCHE UNE SECONDE DEFORMEE (CAS TRACE ARETE ) 459 : *----------------------------------------------------------------------- 460 : IF (IDEFOR.NE.0) THEN 460 : CALL LIROBJ('DEFORME',MDEFO1,0,IMEL3) 461 : ENDIF 462 : 463 : * PRENDRE LE BON TITRE SI IL Y A LIEU 464 : MCHPOI=0 465 : IF (MVECTE.NE.0) THEN 466 : SEGACT MVECTE 467 : MCHPOI=ICHPO(1) 468 : ENDIF 469 : IF (MDEFOR.NE.0) THEN 470 : SEGACT MDEFOR 471 : MCHPOI=ICHDEF(1) 472 : SEGDES MDEFOR 473 : ENDIF 474 : IF (MCHPOI.NE.0) THEN 475 : VALEUR=.TRUE. 476 : SEGACT MCHPOI 477 : IF(MOCHDE(1:12).NE.' ') THEN 478 : READ (MOCHDE,FMT='(A8)') IPVV 479 : IF (IPVV.NE.0) THEN 480 : TITRY=MOCHDE 481 : ENDIF 482 : ENDIF 483 : SEGDES MCHPOI 484 : ENDIF 485 : 486 : *----------------------------------------------------------------------- 487 : * VERIFICATION DE L'EXISTENCE D'UN CHAMPOINT POUR LE TRACE 488 : * DES ISOVALEURS DE CELUI-CI 489 : *----------------------------------------------------------------------- 490 : C MISE A 1 DU FLAG IRETOU POUR INDIQUER CETTE EXISTENCE 490 : CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU) 491 : c-----debut du cas ou on n'a pas lu de chpoint 492 : IF (IRETOU.EQ.0) THEN 493 : * ICONV=0 493 : CALL LIROBJ('MCHAML',MCHA1,0,IRETOU) 494 : IF (IRETOU.EQ.1) THEN 494 : CALL LIROBJ('MMODEL',IPMO1,1,IRETT1) 495 : IF (IRETT1.EQ.0) GOTO 8900 496 : * ENLEVER EVENTUELLEMENT LA PARTIE FROTTEMENT DU MODELE et les relations 497 : * de conformite 498 : MMODE1=IPMO1 499 : SEGINI,MMODEL=MMODE1 500 : N1=0 501 : NS1=0 502 : DO 4300 I=1,KMODEL(/1) 503 : IMODEL=KMODEL(I) 504 : SEGACT IMODEL 505 : * FRO3 506 : IF (NEFMOD.EQ.107) GOTO 4300 507 : * FRO4 508 : IF (NEFMOD.EQ.165) GOTO 4300 509 : * MULT 510 : IF (NEFMOD.EQ.22) GOTO 4300 511 : * Navier_stokes 512 : *PM ceux apres 258 ne sont plus du NS 513 : IF (NEFMOD.GE.195.AND.NEFMOD.LE.258) NS1=1 514 : N1=N1+1 515 : KMODEL(N1)=IMODEL 516 : 4300 CONTINUE 517 : SEGADJ MMODEL 518 : IPMO1=MMODEL 519 : C -TRAITEMENT SPECIAL POUR NAVIER_STOKES 520 : IF(NS1.EQ.1) THEN 520 : CALL CHASPG(IPMO1,MCHA1,MCHAM,IRET,1) 521 : IF (IRET.NE.0) MCHAM=MCHA1 522 : ELSE 523 : * -SINON PASSER LES CHAMELEM AUX NOEUDS 523 : CALL CHASUP(IPMO1,MCHA1,MCHAM,IRET,1) 524 : IF (IRET.NE.0) MCHAM=MCHA1 525 : * lecture eventuelle d'un champ de caracteristiques (poutres, etc ...) 525 : CALL LIROBJ('MCHAML',MCAR1,0,IRET) 526 : mcara=mcar1 526 : IF (IRET.EQ.1) CALL CHASUP(IPMO1,MCAR1,MCARA,IRET,1) 527 : ENDIF 528 : * -FIN DE LA DISTINCTION NAVIER_STOKES / AUTRES CAS 529 : * on ne les transforme plus en champoint. On travaille 530 : * directement dessus 530 : * CALL CHAMPO(MCHAM,1,MCHPOI,IY) 530 : * IF(IRET.EQ.0) CALL DTCHAM(MCHAM) 531 : * IF (ICONV.EQ.1) THEN 531 : * CALL DTMODL(IPMO1) 531 : * IF (IRET.EQ.0) CALL DTCHAM(MCHA1) 532 : * ENDIF 533 : ENDIF 534 : IF (IERR.NE.0) GOTO 8900 535 : ENDIF 536 : c-----fin du cas ou on n'a pas lu de chpoint 537 : IF (ICHISO.EQ.0) ICHISO=IRETOU 538 : IF (IRETOU.EQ.1) VALEUR=.TRUE. 539 : C 540 : *----------------------------------------------------------------------- 541 : * STOP SI TRACE ARETE DE DEFORME (CAS OU IL EN MANQUE UNE) 542 : *----------------------------------------------------------------------- 543 : IF (IDEFOR.NE.0 .AND. IARET.NE.0 .AND. IMEL3.EQ.0) GOTO 8900 544 : 545 : *----------------------------------------------------------------------- 546 : * INIT ENVIRONNEMENT GRAPHIQUE 547 : *----------------------------------------------------------------------- 548 : * point de rebranchement apres nouveau point de vu 549 : 4210 CONTINUE 550 : NBPTS=XCOOR(/1)/(IDIM+1) 550 : CALL TREFF 551 : IF(TXTIT.NE.' ') TITRY=TXTIT 551 : CALL TRINIT(25,DIOCA2,DIOCA2,TITRY,0.15,VALEUR,NCOUMA) 551 : CALL TRCLIK(KCLICK) 552 : C 553 : IF (MDEFOR.EQ.0.AND.MVECTE.EQ.0) GOTO 6000 554 : C C'EST UNE DEFORMEE OU UN VECTEUR QUE L'ON VEUT FAIRE ON ANNULE 555 : C LES OPTIONS INCOMPATIBLES 556 : IQUALI=0 557 : INUMNO=0 558 : INUMEL=0 559 : IDEFCO=0 560 : IECLAT=0 561 : C IFADES=0 CAS A DISCUTER ???? 562 : 563 : *----------------------------------------------------------------------- 564 : * EXTRAIT DES DEFORMES LE MAILLAGE, LES COORD. POINTS ... 565 : *----------------------------------------------------------------------- 566 : 1234 IF (MDEFOR.NE.0) THEN 566 : CALL CREDEF(KABEL,KABCOR,KABCPR,MDEFOR,LABCO2,AMPIMP) 566 : IF (IMEL3.NE.0) CALL CREDEF(KABEL2,KABCO3,KABCP2,MDEFO1,LABCO3, 567 : > AMPIMP) 568 : ENDIF 568 : IF (MVECTE.NE.0) CALL CREVEC(MELEME,ICPR,KABCOR,LABCO2,MVECTE,0) 569 : 570 : *----------------------------------------------------------------------- 571 : * CALCUL DU CADRE AVANT DE CYCLER SUR LA SUITE (EN MODIFIANT PROJEC) 572 : * SUR LA DEFORMEE PRINCIPALE 573 : *----------------------------------------------------------------------- 574 : C PP + option DIRE 574 : CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ, 575 : * 0,XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT,cgrav,diloc,ldire,axez) 576 : C TRACER CARRE FAIT DANS TRINIT SI NECESSAIRE 577 : XMIN=XMINT 578 : XMAX=XMAXT 579 : * XMAX=MAX(XMAXT,XMIN+YMAXT-YMINT,XMIN+ZMAXT-ZMINT) 580 : YMIN=YMINT 581 : YMAX=YMAXT 582 : * YMAX=MAX(YMAXT,YMIN+XMAXT-XMINT,YMIN+ZMAXT-ZMINT) 583 : ZMIN=ZMINT 584 : ZMAX=ZMAXT 585 : * ZMAX=MAX(ZMAXT,ZMIN+XMAXT-XMINT,ZMIN+XMAXT-XMINT) 586 : * Modif des marges 587 : * Ancien : 588 : * XDEC=(XMAX-XMIN)*0.01 589 : * Nouveau : 590 : XDEC=(XMAX-XMIN)*0.1 591 : XMAX=XMAX+XDEC 592 : YMAX=YMAX+XDEC 593 : ZMAX=ZMAX+XDEC 594 : XMIN=XMIN-XDEC 595 : YMIN=YMIN-XDEC 596 : ZMIN=ZMIN-XDEC 597 : IF (IRESU.NE.1) THEN 598 : XMI=XMIN 599 : XMA=XMAX 600 : YMI=YMIN 601 : YMA=YMAX 602 : ZMI=ZMIN 603 : ZMA=ZMAX 604 : ENDIF 604 : CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET) 605 : IF (MDEFOR.NE.0) THEN 606 : SEGACT MDEFOR 607 : NDEF=KABCPR(/1) 607 : IF (IANIM.NE.0) CALL TRANIM(IANIM,NDEF) 608 : ENDIF 609 : IDEFOR=NDEF 610 : KDEFOR=NDEF 611 : IF (MVECTE.NE.0) THEN 612 : SEGACT MVECTE 613 : NVEC=AMPF(/1) 614 : NDEF=1 615 : IDEFOR=NVEC 616 : ENDIF 617 : 618 : 619 : *----------------------------------------------------------------------- 620 : * 621 : * ON BOUCLE SUR LES DEFORMES (OU LES VECTEURS) 622 : * 623 : *----------------------------------------------------------------------- 624 : 625 : * d'abord on calcule si necessaire le min et max general 626 : vchmin=xsgran 627 : vchmax=-xsgran 628 : if (mdefor.ne.0.and.ichiso.ne.0.and.mlreel.eq.0) 628 : > CALL vchbor(mdefor,vchmin,vchmax) 629 : 630 : IDEF=0 631 : *>>>> DEBUT DE LA BOUCLE PRINCIPALE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> 632 : 6099 CONTINUE 633 : IDEF=IDEF+1 634 : IF (IDEF.GT.NDEF) GOTO 6100 635 : 636 : c cas animation 636 : IF (IANIM.NE.0) CALL TRIMAG(IDEF) 637 : 638 : c cas deformee 639 : IF (MDEFOR.NE.0) THEN 640 : VCHC(MIN(NDEFMX,IDEF))=REAL(AMPL(MIN(NDEFMX,IDEF))) 641 : if (ampimp.ge.xsgran/2.and.NISO.gt.0) 642 : > ampimp=REAL(AMPL(1)) 643 : C POUR AFFICHER CORRECTEMENT DEFORME SUR ISOVALEUR 644 : SIAMPL=REAL(AMPL(IDEF)) 645 : If(ampimp.lt.xsgran/2.)siampl=ampimp 646 : C JCARDO IF (IDEF.EQ.1) SIAMPL=AMPIMP 647 : c JCARDO IF (IDEF.EQ.1) VCHC(1)=AMPIMP 648 : ICHL(MIN(NDEFMX,IDEF))=JCOUL(MIN(NDEFMX,IDEF)) 649 : KSCDEF=JCOUL(MIN(NDEFMX,IDEF)) 650 : ENDIF 651 : IF (MDEFOR.NE.0) THEN 652 : ICPR=KABCPR(IDEF) 653 : MELEME=KABEL(IDEF) 654 : XCORD=KABCOR(IDEF) 655 : ITE=XCORD(/2) 656 : SEGACT MDEFOR 657 : IF (MDCHP(IDEF).NE.0) MCHPOI=MDCHP(IDEF) 658 : IF (MDCHEL(IDEF).NE.0) MCHAM=MDCHEL(IDEF) 659 : IF (MDMODE(IDEF).NE.0) IPMO1=MDMODE(IDEF) 660 : ENDIF 661 : 662 : c recup du MELEME et du KABEL si DEFORMES ou de CREVEC si VECTEURS 663 : IPT1=MELEME 664 : if (ite.eq.0) ITE=ICPR(/1) 665 : * GOTO 6010 666 : 667 : C---- POINT D'ARRIVEE EN L'ABSENCE DE DEFORMES ET DE VECTEURS ---------- 668 : 6000 CONTINUE 669 : IF (ICHISO.EQ.1) THEN 670 : NISO=1 671 : * On ne sait indiquer les isovaleurs que sur une seule deformee 671 : * IF (NDEF.GT.1) CALL ERREUR(283) 672 : IF (IERR.NE.0) GOTO 8900 673 : IF (ISOTYP.GT.0.AND.IDIM.EQ.3) ICACHE=1 674 : ENDIF 675 : 676 : c les operations suivantes ne doivent etre realisée qu'une seule 677 : c fois, sinon on saute en 6011 678 : IF (IDEF.NE.1) GOTO 6011 679 : 680 : *----------------------------------------------------------------------- 681 : * LECTURE MAILLAGE PRINCIPAL (sauf cas deformee et chamelem) 682 : *----------------------------------------------------------------------- 683 : if (ipv.eq.0) then 684 : IF (IDEFOR.EQ.0.and.mcham.eq.0) THEN 684 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 685 : IF (IERR.NE.0) GOTO 8900 686 : melsau=meleme 687 : ENDIF 688 : *----------------------------------------------------------------------- 689 : * LECTURE EVENTUELLE D'UN 2ND MAILLAGE 690 : *----------------------------------------------------------------------- 690 : CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU) 691 : IMEL2=IRETOU 692 : IF (IMEL2.EQ.0.AND.IARET.EQ.1.AND.IDEFOR.EQ.0) GOTO 8900 693 : c IF (MDEFOR.EQ.0) then 694 : * mdefos=mdefor 695 : * MDEFOR=MELEME 696 : c endif 696 : CALL REFUS 697 : endif 698 : 699 : 6011 CONTINUE 700 : 701 : C POUR ETRE L'IDENTITE SUR L'OBJET 702 : 703 : C INTERPOLATION CAS DES ISO 704 : IF (NISO.NE.0) THEN 705 : * ici on rajoute une structure recevant les chamelems 706 : SEGINI VCPCHA 707 : vchmin=xsgran 708 : vchmax=-vchmin 708 : CALL AVISO(MELEME,MCHPOI,mcham,ipmo1,VCPCHA,VCHC,NISO,NCOUMA, 709 : > VCHMIN,VCHMAX,MLREEL,MCARA,NCOMP,LCOMP,COMPCH,ISOVU) 710 : IF (IERR.NE.0) GOTO 8900 711 : ENDIF 712 : 713 : C CAS D'UNE COUPE 714 : IF (ICOUP.EQ.1) THEN 715 : if (melemi.eq.0) melemi=meleme 716 : if (melei2.eq.0) melei2=melem2 717 : * write(6 ,*) ' on doit faire une coupe ' 718 : IF (IDEFOR.EQ.0.AND.MVECTE.EQ.0) THEN 718 : CALL CRCOUP(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA, 719 : * MELEM2,MCOU2,mcham,isect) 720 : ELSE 721 : KABC=KABCOR(IDEF) 722 : XCORD=KABC 723 : SEGACT XCORD 724 : NBCTS=XCORD(/2) 725 : ITE=NBCTS 726 : * INITIALISATION DE IVU (UN ELEMENT PAR POINT) 727 : * IVU=1 POINT VU (EN CAS DE COUPE ) 728 : * IVU<>1 POINT PAS VU 729 : SEGINI IVU 730 : DO 5000 I=1,ITE 731 : IVU(I)=1 732 : 5000 CONTINUE 732 : CALL CRCOU2(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA, 733 : * KABC,ICPR,MELEM2,MCOU2,ITE,IVU,mcham,isect) 734 : ENDIF 735 : ENDIF 736 : 737 : 3001 CONTINUE 738 : 739 : C -ON SAUTE CETTE PARTIE SI DEFORMEE OU VECTEURS 740 : IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6010 741 : C SI MCOUP=0 DECRIT LA VISIBILITE DU DERNIER COMPOSANT DE MELEME 742 : SEGINI ICPR 743 : DO 3010 I=1,ICPR(/1) 744 : ICPR(I)=0 745 : 3010 CONTINUE 746 : ITE=0 747 : SEGACT MELEME 748 : IPT1=MELEME 749 : DO 3003 I=1,MAX(1,LISOUS(/1)) 750 : IF (LISOUS(/1).NE.0) THEN 751 : IPT1=LISOUS(I) 752 : ENDIF 753 : SEGACT IPT1 754 : DO 3005 J=1,IPT1.NUM(/1) 755 : DO 30051 K=1,IPT1.NUM(/2) 756 : IPOIT=IPT1.NUM(J,K) 757 : IF (ICPR(IPOIT).NE.0) GOTO 30051 758 : ITE=ITE+1 759 : ICPR(IPOIT)=ITE 760 : 30051 CONTINUE 761 : 3005 CONTINUE 762 : 3003 CONTINUE 763 : * on complete ICPR avec le 2eme maillage pour que celui ci soit toujours trace 764 : if (imel2.ne.0) then 765 : ipt2=melem2 766 : SEGACT ipt2 767 : IPT1=ipt2 768 : DO 3013 I=1,MAX(1,ipt2.LISOUS(/1)) 769 : IF (ipt2.LISOUS(/1).NE.0) THEN 770 : IPT1=ipt2.LISOUS(I) 771 : ENDIF 772 : SEGACT IPT1 773 : DO 3015 J=1,IPT1.NUM(/1) 774 : DO 30151 K=1,IPT1.NUM(/2) 775 : IPOIT=IPT1.NUM(J,K) 776 : IF (ICPR(IPOIT).NE.0) GOTO 30151 777 : ITE=ITE+1 778 : ICPR(IPOIT)=ITE 779 : 30151 CONTINUE 780 : 3015 CONTINUE 781 : 3013 CONTINUE 782 : endif 783 : NBCTS=ITE 784 : DO 5011 I=NBPTS+1,XCOOR(/1)/(IDIM+1) 785 : IF (ICPR(I).EQ.0) THEN 786 : ITE=ITE+1 787 : ICPR(I)=ITE 788 : ENDIF 789 : 5011 CONTINUE 790 : 6010 CONTINUE 791 : C -FIN DE LA PARTIE SAUTEE SI DEFORMEE OU VECTEURS 792 : C 793 : C EN CAS DE TRACE ECLATE ON PROCEDE DIFFEREMMENT 794 : IF (IECLAT.EQ.1) GOTO 4200 795 : 796 : C ITE EST LE NOMBRE DE POINTS A TRACER ICPR LE TABLEAU 797 : C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS 798 : IMELIN=MELEME 799 : MCOUIN=MCOUP 800 : *---------------------------------------------------------- 801 : * LE 2ND MAILLAGE DEVIENT MAILLAGE PRINCIPAL - LES POINTS VUS 802 : * ONT ETE CALCULES SUR LE 1ER MAILLAGE - (IDEM DEFO) 803 : *---------------------------------------------------------- 804 : IF (IMEL2.NE.0) THEN 805 : MELEM3=MELEME 806 : MELEME=MELEM2 807 : ENDIF 808 : IF (IMEL2.NE.0) MCOUP =MCOU2 809 : IF (IMEL3.NE.0) THEN 810 : MELEM3=KABEL(IDEF) 811 : MELEME=KABEL2(IDEF) 812 : * KABCOR=KABCOR(IDEF) 813 : ICPR=KABCPR(IDEF) 814 : * LABCO2=LABCO3 815 : ENDIF 816 : IPT1=MELEME 817 : SEGACT MELEME 818 : *---------------------------------------------------------- 819 : * REALISATION DU TABLEAU DES CONNECTIONS 820 : * KON(3,VOISIN,NOEUD) : 821 : * KON(1,V,N)=Numero DU V-IEME NOEUD RELIE PAR UN SEGMENT AU NOEUD N 822 : * KON(2,V,N)=COULEUR DU V-IEME NOEUD RELIE PAR UN SEGMENT A N 823 : * Il peut y avoir plusieurs couleurs collationnees en binaire 824 : * par ajout de puissances de 2 825 : * KON(3,V,N)=0 si codage couleur direct, 1 si codage binaire 826 : * RMQ: SI N=NBCONR, RENVOI SUR LISTE DE NOEUDS VOISINS 827 : *---------------------------------------------------------- 828 : * Pour permettre les isovaleurss sur les poutres, on exclue de ce tableau 829 : * ce qui vient des SEG2 et SEG3 si on est en isovaleur 830 : * 831 : NBCON =9 832 : NBCONR=NBCON-1 833 : NMAX =(12*ITE)/NBCON+200 834 : SEGINI KON 835 : C MISE A ZERO DU TABLEAU KON 836 : DO I=1,NMAX 837 : DO J=1,NBCON 838 : KON(1,J,I)=0 839 : KON(2,J,I)=0 840 : KON(3,J,I)=0 841 : ENDDO 842 : ENDDO 843 : 844 : C FABRICATION DU TABLEAU DES CONNECTIONS 845 : ICHAIN=ITE 846 : COUPE=.FALSE. 847 : * Boucle sur les Partitions 848 : DO 222 IO=1,MAX(1,LISOUS(/1)) 849 : IF (LISOUS(/1).NE.0) THEN 850 : COUPE=.FALSE. 851 : IF (IO.EQ.LISOUS(/1).AND.MCOUP.NE.0) COUPE=.TRUE. 852 : IPT1=LISOUS(IO) 853 : ENDIF 854 : SEGACT IPT1 855 : K=IPT1.ITYPEL 856 : * PRISE EN COMPTE DES BLOCAGES 857 : IF (K.EQ.22) BLOCAG=.TRUE. 858 : IF (K.EQ.1) CROIX =.TRUE. 859 : * poutres+iso on saute 860 : if ((k.eq.2.or.k.eq.3).and.niso.ne.0.and. 861 : > meleme.ne.melem2) goto 222 862 : * 863 : IDEP=LPT(K) 864 : IFIN1=IDEP+2*LPL(K)-2 865 : IFIN2=IFIN1 866 : IF (LPL(K).EQ.0) THEN 867 : IF (LPT(K).EQ.0)THEN 868 : GOTO 2225 869 : ELSE 870 : C Polygone 871 : IFIN1=IDEP+2*IPT1.NUM(/1)-2 872 : IFIN2=IFIN1 - 2 873 : ENDIF 874 : ENDIF 875 : 876 : IF (IDEFOR.NE.0.AND.MDEFOR.NE.0) SEGACT MDEFOR 877 : 878 : * Boucle sur les elements de la partition 879 : DO 223 I=1,IPT1.NUM(/2) 880 : IF (IDEFOR.EQ.0.OR.MVECTE.NE.0.OR.IANIM.NE.0) THEN 881 : KSCOLI=IPT1.ICOLOR(I) 882 : * IF (KSCOLI.EQ.0) KSCOLI=IDCOUL 883 : ELSE 884 : KSCOLI=KSCDEF 885 : C+PP couleur par defaut pour les deformees = celle du maillage 886 : IF (KSCOLI.EQ.0) KSCOLI=IPT1.ICOLOR(I) 887 : C+PP 888 : * IF (KSCOLI.EQ.0) KSCOLI=IDCOUL 889 : ENDIF 890 : IS=1 891 : DO 2 J=IDEP,IFIN1,2 892 : IF (J.LE.IFIN2) THEN 893 : N1=ICPR(IPT1.NUM(KSEGM(J),I)) 894 : N2=ICPR(IPT1.NUM(KSEGM(J+1),I)) 895 : ELSE 896 : C Polygone 897 : N1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I)) 898 : N2=ICPR(IPT1.NUM(KSEGM(1),I)) 899 : ENDIF 900 : IF (COUPE) THEN 901 : C NE FONCTIONNE QUE SUR DES TRI3 902 : IS=IS*2 903 : IF (MOD((2*MCOUP(I))/IS,2).EQ.0) GOTO 2 904 : ENDIF 905 : NI=N1 906 : NJ=N2 907 : IF (N1*N2.EQ.0) GOTO 8 908 : * Attribution de la couleur au segment correspondant dans KON : 909 : IPO=0 910 : KSCOL1=KSCOLI 911 : 9 CONTINUE 912 : NII=NI 913 : 7 DO 4 K=1,NBCONR 914 : IF (KON(1,K,NI).GT.NJ) GOTO 4 915 : IF (KON(1,K,NI).LT.NJ) THEN 916 : KSAUV1=NJ 917 : KSCOL1=KSCOLI 918 : KSCOD1=0 919 : GOTO 5 920 : ENDIF 921 : 922 : * recherche si KSCOL1 fait partie des couleurs du segment, 923 : * si oui (JJ=1), deje traite 924 : * sinon (JJ=0), on l'ajoute a la liste de couleurs 925 : * et on met a jour celle des segments eventuellement confondus 926 : JJ=0 927 : * IF (KSCOL1.EQ.0) KSCOL1=IDCOUL 928 : *PM IF (KON(2,K,NI).LT.300) KON(2,K,NI)= 929 : *PM $ 300+(2**(KON(2,K,NI)-1)) 930 : IF (KON(3,K,NI).EQ.0) THEN 931 : * Passage en binaire si pas deja fait 932 : KON(3,K,NI)=1 933 : IK=KON(2,K,NI) 934 : KON(2,K,NI)=IPUIS2(IK) 935 : * Il n'y a qu'une seule couleur de codee, facile a tester 936 : IF (IK.EQ.KSCOL1) JJ=1 937 : ELSE 938 : * potentiellement plusieurs couleurs codees, a tester 939 : *PM ICAL=KON(2,K,NI)-300 940 : ICAL=KON(2,K,NI) 941 : *PM (NBCOUL-1) au lieu de 7 942 : DO II=(NBCOUL-1),KSCOL1,-1 943 : IF (IPUIS2(II).LE.ICAL) THEN 944 : IF (II.EQ.KSCOL1) THEN 945 : JJ=1 946 : ELSE 947 : ICAL=ICAL-IPUIS2(II) 948 : ENDIF 949 : ENDIF 950 : ENDDO 951 : ENDIF 952 : 953 : * Si cette couleur existe, le segment a deja ete traite 954 : IF (JJ.EQ.1) GOTO 2 955 : 956 : * sinon on ajoute la couleur a la liste binaire de couleurs du segment 957 : KON(2,K,NI)=KON(2,K,NI)+IPUIS2(KSCOL1) 958 : 959 : * ainsi qu'aux segments confondus eventuels 960 : 1111 CONTINUE 961 : DO II=1,NBCONR 962 : IF (KON(1,II,NJ).EQ.NII) THEN 963 : KON(2,II,NJ)=KON(2,K,NI) 964 : KON(3,II,NJ)=KON(3,K,NI) 965 : GOTO 1113 966 : ENDIF 967 : ENDDO 968 : IF (KON(1,NBCON,NJ).NE.0) THEN 969 : NJ=KON(1,NBCON,NJ) 970 : GOTO 1111 971 : ENDIF 972 : 1113 CONTINUE 973 : GOTO 2 974 : 4 CONTINUE 975 : 976 : * on passe au noeud suivant dans la chaine, 977 : * ou on l'incremente et on la met a jour si on est arrive au bout 978 : IF (KON(1,NBCON,NI).NE.0) THEN 979 : NI=KON(1,NBCON,NI) 980 : GOTO 7 981 : ENDIF 982 : 6 KSAUV1=NJ 983 : KSCOL1=KSCOLI 984 : KSCOD1=1 985 : 301 ICHAIN=ICHAIN+1 986 : IF (ICHAIN.EQ.NMAX) THEN 987 : NMAX=NMAX+1000 988 : SEGADJ KON 989 : * WRITE (IOIMP,*) 'PRTRAC: KON agrandi' 990 : ENDIF 991 : KON(1,NBCON,NI)=ICHAIN 992 : K=1 993 : NI=ICHAIN 994 : 995 : * On insere la nouvelle connexion NJ a la place de la 996 : * connexion actuelle, et on decale le reste d'un cran 997 : 5 CONTINUE 998 : KSAUV=KON(1,K,NI) 999 : KSCOL=KON(2,K,NI) 1000 : KSCOD=KON(3,K,NI) 1001 : * IF (KSCOL1.EQ.0) KSCOL1=IDCOUL 1002 : KON(1,K,NI)=KSAUV1 1003 : KON(2,K,NI)=KSCOL1 1004 : KON(3,K,NI)=KSCOD1 1005 : KSAUV1=KSAUV 1006 : KSCOL1=KSCOL 1007 : KSCOD1=KSCOD 1008 : IF (KSAUV.EQ.0) GOTO 3 1009 : KDEP=K+1 1010 : IF (KDEP.EQ.NBCON) GOTO 302 1011 : 303 CONTINUE 1012 : DO KHE=KDEP,NBCONR 1013 : KSAUV=KON(1,KHE,NI) 1014 : KSCOL=KON(2,KHE,NI) 1015 : KSCOD=KON(3,KHE,NI) 1016 : * IF (KSCOL1.EQ.0) KSCOL1=IDCOUL 1017 : KON(1,KHE,NI)=KSAUV1 1018 : KON(2,KHE,NI)=KSCOL1 1019 : KON(3,KHE,NI)=KSCOD1 1020 : IF (KSAUV.EQ.0) GOTO 3 1021 : KSAUV1=KSAUV 1022 : KSCOL1=KSCOL 1023 : KSCOD1=KSCOD 1024 : ENDDO 1025 : 302 CONTINUE 1026 : IF (KON(1,NBCON,NI).EQ.0) GOTO 301 1027 : NI=KON(1,NBCON,NI) 1028 : KDEP=1 1029 : GOTO 303 1030 : 3 IF (NJ.NE.N2.OR.IPO.EQ.1) GOTO 2 1031 : NI=N2 1032 : NJ=N1 1033 : IPO=1 1034 : GOTO 9 1035 : 2 CONTINUE 1036 : 223 CONTINUE 1037 : 2225 CONTINUE 1038 : IF (LISOUS(/1).NE.0) SEGDES IPT1 1039 : 222 CONTINUE 1040 : GOTO 10 1041 : * Operation malvenue. Resultat douteux 1041 : 8 CALL ERREUR(23) 1042 : 1043 : 10 CONTINUE 1044 : 1045 : SEGDES MELEME 1046 : *TC IF (MCOU2.NE.0) THEN 1047 : C NETTOYAGE APRES COUPE 1048 : * SEGSUP MCOUP 1049 : * SEGACT MELEME 1050 : * DO 8802 IO=1,LISOUS(/1) 1051 : * IPT1=LISOUS(IO) 1052 : * SEGSUP IPT1 1053 : * 8802 CONTINUE 1054 : * SEGSUP MELEME 1055 : * ENDIF 1056 : MELEME=IMELIN 1057 : MCOUP =MCOUIN 1058 : C GESTION DU TABLEAU ICPR(COMPTEUR DE COULEUR) 1059 : C ITEST(II) = 1 si la couleur appartient a la liste du point, 0 sinon 1060 : C (= conversion de KON(2,I,J) en tableau) 1061 : C ICHC(I) : nb de segments sur lesquels apparait la couleur I 1062 : C On ramene, si code en binaire, KON(2,.,.) dans l'intervalle 1063 : C [0;NBCOUL-1] en melangeant eventuellement les couleurs des 1064 : C segments confondus 1065 : DO 310 I=1,NBCONR 1066 : DO 3101 J=1,KON(/3) 1067 : *PM on ecrit IK au lieu de KON(2,I,J) pour economiser l'acces memoire 1068 : IK=KON(2,I,J) 1069 : IF (IK.NE.0) THEN 1070 : *PM IF (IK.LE.9) THEN 1071 : IF (KON(3,I,J).EQ.0) THEN 1072 : * KON(2,.,.) est deja code dans l'intervalle [0;NBCOUL-1] 1073 : * soit que ce segment est seul, soit qu'il a deja ete rencontre 1 fois 1074 : ICHC(IK)=ICHC(IK)+1 1075 : ELSE 1076 : * cas ou KON est code en puissances de 2 dans [1;2**(NBCOUL-1)] 1077 : *PM NBCOUL-1 au lieu de 7 1078 : * tablage des couleurs possibles. IK finit a 0 1079 : DO II=1,(NBCOUL-1) 1080 : ITEST(II)=0 1081 : ENDDO 1082 : *PM NBCOUL-1 au lieu de 7 1083 : DO II=(NBCOUL-1),1,-1 1084 : IF (IPUIS2(II).LE.IK) THEN 1085 : IK=IK-IPUIS2(II) 1086 : ITEST(II)=1 1087 : ENDIF 1088 : ENDDO 1089 : 1090 : * Couleur finale du segment a tracer 1091 : IF (IDEFCO.EQ.1.AND.ITEST(IICOL).EQ.1) THEN 1092 : * Le segment est eligible 1093 : IK=IICOL 1094 : ELSE 1095 : *PM NBCOUL-1 au lieu de 7 1096 : DO II=1,NBCOUL-1 1097 : IF (ITEST(II).EQ.1) THEN 1098 : * si plusieurs couleurs, on les melange 1099 : IF (IK.EQ.0) THEN 1100 : IK=II 1101 : ELSE 1102 : IK=ITABM(IK,II) 1103 : ENDIF 1104 : ENDIF 1105 : ENDDO 1106 : ENDIF 1107 : KON(2,I,J)=IK 1108 : KON(3,I,J)=0 1109 : ICHC(IK)=ICHC(IK)+1 1110 : ENDIF 1111 : ENDIF 1112 : 3101 CONTINUE 1113 : 310 CONTINUE 1114 : SEGDES KON 1115 : IF (IRESU.EQ.6) GOTO 4999 1116 : 1117 : C POINT D'ARRIVEE SI ECLATE 1118 : 4200 CONTINUE 1119 : segact icpr 1120 : SEGINI XPROJ 1121 : IF (IDEFOR.NE.0) GOTO 6030 1122 : * IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6030 A VOIR PV 1123 : C LA TROISIEME COORDONNEE PROJETEE EST LA DISTANCE A L'OEIL 1123 : CALL PROJEC(ICPR,XPROJ,IOEIL,CGRAV,axez) 1124 : SEGDES ICPR 1125 : C 1126 : C 1127 : XMIN=1E30 1128 : XMAX=-XMIN 1129 : YMIN=XMIN 1130 : YMAX=XMAX 1131 : ZMIN=XMIN 1132 : ZMAX=XMAX 1133 : DO I=1,ITE 1134 : XMIN=MIN(XMIN,XPROJ(1,I)) 1135 : XMAX=MAX(XMAX,XPROJ(1,I)) 1136 : YMIN=MIN(YMIN,XPROJ(2,I)) 1137 : YMAX=MAX(YMAX,XPROJ(2,I)) 1138 : ZMIN=MIN(ZMIN,XPROJ(3,I)) 1139 : ZMAX=MAX(ZMAX,XPROJ(3,I)) 1140 : ENDDO 1141 : C 1142 : XDEC=XMAX-XMIN 1143 : YDEC=YMAX-YMIN 1144 : ZDEC=ZMAX-ZMIN 1145 : * Modif des marges 1146 : * Nouveau : 1147 : DDEC=MAX(XDEC,YDEC,ZDEC)*0.1 1148 : * MODIF JCARDO 28/02/2012 : DDEC vaut maintenant XSZPRE au minimum 1149 : * (évite des erreurs de cancellation) 1150 : DDEC=MAX(DDEC,xszpre) 1151 : * DDEC=MAX(DDEC,xspeti) 1152 : XMAX=XMAX+DDEC 1153 : XMIN=XMIN-DDEC 1154 : YMIN=YMIN-DDEC 1155 : YMAX=YMAX+DDEC 1156 : ZMIN=ZMIN-DDEC 1157 : ZMAX=ZMAX+DDEC 1158 : XMI=XMIN 1159 : XMA=XMAX 1160 : YMI=YMIN 1161 : YMA=YMAX 1162 : ZMI=ZMIN 1163 : ZMA=ZMAX 1163 : CALL DFENET(XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,X1,X2,Y1,Y2,FENET) 1164 : GOTO 6040 1165 : 6030 CONTINUE 1166 : C FAIRE ICI LA PROJECTION DE LA DEFORMEE 1167 : C PP + option DIRE 1167 : CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ, 1168 : * IDEF,XMIN,YMIN,XMAX,YMAX,ZMIN,ZMAX,cgrav,diloc,ldire,axez) 1169 : 6040 CONTINUE 1170 : * 1171 : * 1172 : * BERTIN: AFFICHAGE DE LA DATE 1173 : IF (ZDATE) THEN 1173 : CALL GIBDAT(JOUR,MOIS,IANNEE) 1174 : iannee=mod(iannee,100) 1175 : **TC TIME=FDATE() 1176 : BUFFER(1:22)=' / /20 ' 1177 : WRITE (BUFFER(4:5),FMT='(I2)') JOUR 1178 : WRITE (BUFFER(7:8),FMT='(I2)') MOIS 1179 : WRITE (BUFFER(12:13),FMT='(I2)') IANNEE 1180 : **TC WRITE (BUFFER(15:22),FMT='(A8)') TIME(12:20) 1181 : TXX=-0.7 1182 : TYY=-0.5 1182 : * CALL TRBOX(0.8,0.8) 1183 : READ(BUFFER(1:22),'(A26)') BUFFER 1183 : * CALL TRBOX(1./0.8,1./0.8) 1184 : ENDIF 1185 : * BERTIN: FIN AFFICHAGE DE LA DATE 1186 : 1187 : *---------------------------------------------------------- 1188 : * INITIALISATION DE IVU SI NON FAIT 1189 : * IVU=1 PT VU 1190 : * IVU<>1 PT PAS VU 1191 : *---------------------------------------------------------- 1192 : 4999 CONTINUE 1193 : IF (IVU.EQ.0) THEN 1194 : SEGINI IVU 1195 : DO 4997 I=1,ITE 1196 : IVU(I)=1 1197 : 4997 CONTINUE 1198 : ENDIF 1199 : * METTRE NON CACHABLE LES POINTS DU PLAN DE COUPE 1200 : SEGADJ IVU 1201 : * IF (ICACHE.NE.0.AND.NBCTS.NE.0) THEN CORRECTION PV 1202 : IF (NBCTS.NE.0) THEN 1203 : DO 5010 I=NBCTS+1,ITE 1204 : IVU(I)=2 1205 : 5010 CONTINUE 1206 : ENDIF 1207 : C 1208 : *PM NBCOUL-1 au lieu de 8 1209 : DO I=1,NBCOUL-1 1210 : ICHCS(I)=ICHC(I) 1211 : ENDDO 1212 : * cacher en soft si pas opengl 1213 : if (iogra.ne.6) then 1214 : * DEBUT MODIF 1215 : IF (ICACHE.NE.0) THEN 1216 : IF (IARET.EQ.0) THEN 1216 : CALL TIRET3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX, 1217 : . IVU,NELEM,TMIN,TMAX,MCOUP) 1218 : ELSE 1219 : 1219 : CALL TIRET3(XPROJ,MELEM3,ICPR,XMIN,XMAX,YMIN,YMAX, 1220 : . IVU,NELEM,TMI,TMAX,MCOUP) 1221 : ENDIF 1222 : ENDIF 1223 : * FIN MODIF 1224 : endif 1225 : 1226 : *------------------------------------------------------------ 1227 : * CAS DU TRACE PAR FACE APPEL AU SOUS-PROGRAM FACED 1228 : * POUR REMPLIR LES FACES 1229 : *------------------------------------------------------------ 1230 : IF (IECLAT.NE.1) THEN 1231 : IF (IFADES.EQ.1) THEN 1231 : CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,1) 1232 : ELSEIF (IFADES.EQ.0.AND.IOGRA.EQ.6.AND.ICACHE.EQ.1) THEN 1233 : * TRACe DES ELEMENTS EN EFFACEMENT 1233 : CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,0) 1234 : ENDIF 1235 : ENDIF 1236 : IF (IERR.NE.0) GOTO 8900 1237 : 1238 : *------------------------------------------------------------ 1239 : * 1240 : * CAS OU ON VEUT TRACER LES ISOVALEURS D UN OBJET DE TYPE CHAMPOINT 1241 : * 1242 : *------------------------------------------------------------ 1243 : IF (NISO.NE.0) THEN 1244 : * signaler le nombre d'iso 1244 : CALL FVALIS(0,IRESU,NHAUT,NISO) 1245 : PTI=XMAX-XMIN 1245 : CALL ATISO(MELEME,ICPR,XPROJ,VCPCHA,VCHC,IVU,PTI,NISO,MCOUP, 1246 : > mcham) 1247 : ENDIF 1248 : * 1249 : 6080 CONTINUE 1250 : IF (IERR.NE.0) RETURN 1251 : IF (ICACHE.EQ.1) THEN 1252 : LTSEGS=1000 1253 : SEGINI NTSEG 1254 : LTSEG=0 1255 : endif 1256 : 5001 CONTINUE 1257 : C IF (IECLAT.EQ.1.OR.IFADES.EQ.1) GOTO 4201 PV JUIN 86 1258 : IF (IECLAT.EQ.1) GOTO 4201 1259 : C TRACE DES SEGMENTS D'UNE COULEUR EN LES GROUPANT EN UNE LIGNE 1260 : SEGACT KON*MOD 1261 : *PM NBCOUL-1 au lieu de 8 1262 : DO 70 LI=0,NBCOUL-1 1263 : IF (IDEFCO.EQ.1 .AND. LI.NE.IICOL) GOTO 70 1263 : C PP CALL CHCOUL(LI) 1264 : C+PP FACE avec trait blanc 1265 : IF (LBLANC) THEN 1265 : CALL CHCOUL(0) 1266 : ELSE 1266 : CALL CHCOUL(LI) 1267 : ENDIF 1268 : C+PP 1269 : C SI ISOVALEUR ET REMPLISSAGE COULEUR EFFACEMENT 1270 : * MODIF JCARDO 8/12/2011 : rajout condition LI=0 1271 : * => on force NOIR seulement si COUL=DEFA 1272 : * MODIF JCARDO 28/02/2012 : rajout condition IMEL2=0 (éventuellement) 1273 : * => on force NOIR seulement s'il y a un 1274 : * seul objet MAILLAGE 1274 : * IF (NISO.NE.0.AND.ISOTYP.GT.0) CALL CHCOUL(IDNOIR) 1275 : IF (LI.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0) 1276 : * IF ((IMEL2.EQ.0.OR.LI.EQ.0).AND.NISO.NE.0.AND.ISOTYP.GT.0) 1276 : & CALL CHCOUL(IDNOIR) 1277 : KAUX=1 1278 : 23 K=KAUX 1279 : IF (IVU(KAUX).LE.0) GOTO 40 1280 : KAUXR=KAUX 1281 : 41 CONTINUE 1282 : DO 19 KL=1,NBCONR 1283 : ITRA=KON(1,KL,K) 1284 : IF (ITRA.LT.0) GOTO 19 1285 : IF (ITRA.EQ.0) GOTO 40 1286 : IF (KON(2,KL,K).NE.LI) GOTO 19 1287 : IF (IVU(ITRA).GE.1) GOTO 21 1288 : 19 CONTINUE 1289 : K=KON(1,NBCON,K) 1290 : IF (K.NE.0) GOTO 41 1291 : 40 KAUX=KAUX+1 1292 : IF (KAUX.GE.ITE+1) GOTO 27 1293 : GOTO 23 1294 : 21 CONTINUE 1294 : IF (ITR.GT.1) CALL POLRL(ITR,XTR,YTR,ZTR) 1295 : ITR=1 1296 : XTR(ITR)=XPROJ(1,KAUXR) 1297 : YTR(ITR)=XPROJ(2,KAUXR) 1298 : ZTR(ITR)=XPROJ(3,KAUXR) 1299 : KPRESS=KAUXR 1300 : GOTO 25 1301 : 24 KL=1 1302 : 25 DO 22 L=KL,NBCONR 1303 : M=KON(1,L,K) 1304 : IF (M.EQ.0) GOTO 23 1305 : IF (M.LT.0) GOTO 22 1306 : IF (KON(2,L,K).NE.LI) GOTO 22 1307 : IF (IVU(M).LE.0) GOTO 22 1308 : GOTO 28 1309 : 22 CONTINUE 1310 : K=KON(1,NBCON,K) 1311 : IF (K.EQ.0) GOTO 23 1312 : GOTO 24 1313 : 28 CONTINUE 1314 : ITR=ITR+1 1315 : XTR(ITR)=XPROJ(1,M) 1316 : YTR(ITR)=XPROJ(2,M) 1317 : ZTR(ITR)=XPROJ(3,M) 1318 : IF (ITR.EQ.40) THEN 1318 : CALL POLRL(ITR,XTR,YTR,ZTR) 1319 : XTR(1)=XTR(ITR) 1320 : YTR(1)=YTR(ITR) 1321 : ZTR(1)=ZTR(ITR) 1322 : ITR=1 1323 : ENDIF 1324 : KON(1,L,K)=-KON(1,L,K) 1325 : M1=M 1326 : 42 DO 43 L=1,NBCONR 1327 : IF (KON(1,L,M1).EQ.0) GOTO 45 1328 : IF (KON(1,L,M1).EQ.KPRESS) GOTO 44 1329 : 43 CONTINUE 1330 : M1=KON(1,NBCON,M1) 1331 : IF (M1.EQ.0) GOTO 45 1332 : GOTO 42 1333 : 44 KON(1,L,M1)=-KON(1,L,M1) 1334 : 45 KPRESS=M 1335 : K=KPRESS 1336 : GOTO 24 1337 : 27 CONTINUE 1337 : IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR) 1338 : ITR=0 1339 : 70 CONTINUE 1340 : IF (ICACHE.EQ.0) GOTO 5002 1341 : 1342 : *---------------------------------------------------------- 1343 : * ON REMPLIT NTSEG AVEC LES SEGMENTS EN PARTIE VUS 1344 : * (OPTION CACHE) 1345 : *---------------------------------------------------------- 1346 : DO 5003 K=1,ITE 1347 : IF (IVU(K).LE.0) GOTO 5003 1348 : KK=K 1349 : 5005 CONTINUE 1350 : DO 5004 KL=1,NBCONR 1351 : ITRA=KON(1,KL,KK) 1352 : IF (ITRA.LT.0) GOTO 5004 1353 : IF (ITRA.EQ.0) GOTO 5003 1354 : IF (LTSEGS-LTSEG.LT.10) THEN 1355 : LTSEGS=LTSEGS+1000 1356 : SEGADJ NTSEG 1357 : ENDIF 1358 : NTSEG(LTSEG+1)=K 1359 : NTSEG(LTSEG+2)=ITRA 1360 : * MODIF JCARDO 28/02/2012 : rajout conditions LICLR=0 (+ éventuellement IMEL2=0) 1361 : * cf. commentaires 100 lignes plus haut... 1362 : * IF (NISO.NE.0.AND.ISOTYP.GT.0) THEN 1363 : LICLR=KON(2,KL,KK) 1364 : IF (LICLR.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN 1365 : * IF ((IMEL2.EQ.0.OR.LICLR.EQ.0) 1366 : * & .AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN 1367 : *PM IDNOIR au lieu de 8 1368 : NTSEG(LTSEG+3)=IDNOIR 1369 : ELSE 1370 : NTSEG(LTSEG+3)=LICLR 1371 : ENDIF 1372 : LTSEG=LTSEG+3 1373 : 5004 CONTINUE 1374 : KK=KON(1,NBCON,KK) 1375 : IF (KK.NE.0) GOTO 5005 1376 : 5003 CONTINUE 1377 : 5002 CONTINUE 1378 : SEGDES KON 1379 : * Trace des petites croix, cas de type POI1 1380 : IF (CROIX) then 1381 : * CALCUL TAILLE POUR LES CROIX 1382 : XDIB=XMAX-XMIN 1383 : YDIB=YMAX-YMIN 1384 : BLOK=MAX(XDIB,YDIB)*0.003 1385 : IPT1=MELEME 1386 : IF (IMEL2.NE.0) IPT1=MELEM2 1387 : SEGACT IPT1 1388 : SEGACT MELEME 1389 : DO 8002 ISOUS=1,MAX(1,LISOUS(/1)) 1390 : IF (LISOUS(/1).NE.0) THEN 1391 : IPT1=LISOUS(ISOUS) 1392 : SEGACT IPT1 1393 : ENDIF 1394 : IF (IPT1.ITYPEL.NE.1) GOTO 8004 1395 : *---------------------------------------------------------- 1396 : * TRACE DES croix 1397 : *---------------------------------------------------------- 1398 : SEGACT IVU,ICPR 1399 : icc = -3 1400 : NBNN=IPT1.NUM(/1) 1401 : DO 8005 IEL=1,IPT1.NUM(/2) 1402 : IF (IVU(ICPR(IPT1.NUM(1,IEL))).GE.1) THEN 1403 : ICOOL=IPT1.ICOLOR(IEL) 1404 : * IF (ICOOL.LE.0) ICOOL=IDCOUL 1405 : *PM IDNOIR au lieu de 8 1406 : IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR 1407 : IF (ICOOL.NE.ICC) THEN 1408 : ICC=ICOOL 1408 : CALL CHCOUL(ICC) 1409 : ENDIF 1410 : XPOS=XPROJ(1,ICPR(IPT1.NUM(1,IEL))) 1411 : YPOS=XPROJ(2,ICPR(IPT1.NUM(1,IEL))) 1412 : ZPOS=XPROJ(3,ICPR(IPT1.NUM(1,IEL))) 1413 : XTR(1)=XPOS+BLOK 1414 : YTR(1)=YPOS 1415 : ZTR(1)=ZPOS 1416 : XTR(2)=XPOS-BLOK 1417 : YTR(2)=YPOS 1418 : ZTR(2)=ZPOS 1418 : CALL POLRL(2,XTR,YTR,ZTR) 1419 : XTR(1)=XPOS 1420 : YTR(1)=YPOS+BLOK 1421 : ZTR(1)=ZPOS 1422 : XTR(2)=XPOS 1423 : YTR(2)=YPOS-BLOK 1424 : ZTR(2)=ZPOS 1424 : CALL POLRL(2,XTR,YTR,ZTR) 1425 : ENDIF 1426 : 8005 CONTINUE 1427 : 8004 CONTINUE 1428 : IF (LISOUS(/1).NE.0) SEGDES IPT1 1429 : 8002 CONTINUE 1430 : SEGDES MELEME 1431 : endif 1432 : * Y A T IL DES BLOCAGES ??? 1433 : IF (.NOT.BLOCAG) GOTO 7000 1434 : * CALCUL TAILLE POUR LES BLOCAGES 1435 : XDIB=XMAX-XMIN 1436 : YDIB=YMAX-YMIN 1437 : BLOK=MAX(XDIB,YDIB)*0.01 1438 : ICC=-3 1439 : SEGACT MELEME 1440 : IPT1=MELEME 1441 : DO 7002 ISOUS=1,MAX(1,LISOUS(/1)) 1442 : IF (LISOUS(/1).NE.0) THEN 1443 : IPT1=LISOUS(ISOUS) 1444 : SEGACT IPT1 1445 : ENDIF 1446 : IF (IPT1.ITYPEL.NE.22) GOTO 7004 1447 : *---------------------------------------------------------- 1448 : * TRACE DES BLOCAGES 1449 : *---------------------------------------------------------- 1450 : SEGACT IVU,ICPR 1451 : NBNN=IPT1.NUM(/1) 1452 : DO 7005 IEL=1,IPT1.NUM(/2) 1453 : ICOOL=IPT1.ICOLOR(IEL) 1454 : * IF (ICOOL.LE.0) ICOOL=IDCOUL 1455 : IF (NBNN.GT.2) THEN 1456 : * IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR 1457 : IF (ICOOL.NE.ICC) THEN 1458 : ICC=ICOOL 1458 : CALL CHCOUL(ICC) 1459 : ENDIF 1460 : JDTRAC=0 1461 : DO 7006 INO=2,NBNN 1462 : INOS=INO+1 1463 : IF (INOS.GT.NBNN) INOS = 2 1464 : IP1=ICPR(IPT1.NUM(INO,IEL)) 1465 : IP2=ICPR(IPT1.NUM(INOS,IEL)) 1466 : IF (IVU(IP1).GE.1.AND.IVU(IP2).GE.1) THEN 1467 : IF (JDTRAC.EQ.0) THEN 1468 : XTR(1)=XPROJ(1,IP1) 1469 : YTR(1)=XPROJ(2,IP1) 1470 : ZTR(1)=XPROJ(3,IP1) 1471 : XTR(2)=XPROJ(1,IP2) 1472 : YTR(2)=XPROJ(2,IP2) 1473 : ZTR(2)=XPROJ(3,IP2) 1473 : CALL POLRL(2,XTR,YTR,ZTR) 1474 : ENDIF 1475 : JDTRAC=1 1476 : ELSEIF (IVU(IP1).GE.1) THEN 1477 : IF (LTSEGS-LTSEG.LT.10) THEN 1478 : LTSEGS=LTSEGS+1000 1479 : SEGADJ NTSEG 1480 : ENDIF 1481 : NTSEG(LTSEG+1)=IP1 1482 : NTSEG(LTSEG+2)=IP2 1483 : NTSEG(LTSEG+3)=ICC 1484 : LTSEG=LTSEG+3 1485 : JDTRAC=0 1486 : ELSEIF (IVU(IP2).GE.1) THEN 1487 : IF (LTSEGS-LTSEG.LT.10) THEN 1488 : LTSEGS=LTSEGS+1000 1489 : SEGADJ NTSEG 1490 : ENDIF 1491 : NTSEG(LTSEG+1)=IP2 1492 : NTSEG(LTSEG+2)=IP1 1493 : NTSEG(LTSEG+3)=ICC 1494 : LTSEG=LTSEG+3 1495 : JDTRAC=0 1496 : ENDIF 1497 : 7006 CONTINUE 1498 : ELSEIF (NBNN.EQ.2.AND.IVU(ICPR(IPT1.NUM(2,IEL))).GE.1) THEN 1499 : IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR 1500 : IF (ICOOL.NE.ICC) THEN 1501 : ICC=ICOOL 1501 : CALL CHCOUL(ICC) 1502 : ENDIF 1503 : XPOS=XPROJ(1,ICPR(IPT1.NUM(2,IEL))) 1504 : YPOS=XPROJ(2,ICPR(IPT1.NUM(2,IEL))) 1505 : ZPOS=XPROJ(3,ICPR(IPT1.NUM(2,IEL))) 1506 : XTR(1)=XPOS+BLOK 1507 : YTR(1)=YPOS 1508 : ZTR(1)=ZPOS 1509 : XTR(2)=XPOS 1510 : YTR(2)=YPOS+BLOK 1511 : ZTR(2)=ZPOS 1512 : XTR(3)=XPOS-BLOK 1513 : YTR(3)=YPOS 1514 : ZTR(3)=ZPOS 1515 : XTR(4)=XPOS 1516 : YTR(4)=YPOS-BLOK 1517 : ZTR(4)=ZPOS 1518 : XTR(5)=XTR(1) 1519 : YTR(5)=YTR(1) 1520 : ZTR(5)=ZTR(1) 1520 : CALL POLRL(5,XTR,YTR,ZTR) 1521 : ENDIF 1522 : 7005 CONTINUE 1523 : 7004 CONTINUE 1524 : IF (LISOUS(/1).NE.0) SEGDES IPT1 1525 : 7002 CONTINUE 1526 : SEGDES MELEME 1527 : 7000 CONTINUE 1528 : if (iogra.eq.6) goto 4202 1529 : IF (ICACHE.NE.0) THEN 1530 : C PP FACE avec trait blanc 1530 : CALL DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX, 1531 : * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO,lblanc,LTSEG) 1532 : C PP * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO) 1533 : ENDIF 1534 : GOTO 4202 1535 : 4201 CONTINUE 1536 : *---------------------------------------------------------- 1537 : * 1538 : * TRACE ECLATE DES ELEMENTS 1539 : * 1540 : *---------------------------------------------------------- 1541 : SEGACT ICPR 1542 : C IF (IFADES.EQ.1) GOTO 4400 PV JUIN 86 1543 : SEGACT MELEME 1544 : ICOLE=0 1545 : IPT1=MELEME 1546 : DO 4111 IO=1,MAX(1,LISOUS(/1)) 1547 : IF (LISOUS(/1).NE.0) THEN 1548 : IPT1=LISOUS(IO) 1549 : SEGACT IPT1 1550 : ENDIF 1551 : K=IPT1.ITYPEL 1552 : IDEP=LPT(K) 1553 : IFIN=IDEP+2*LPL(K)-2 1554 : IFIN2=IFIN 1555 : IF (LPL(K).EQ.0) THEN 1556 : IF (LPT(K).EQ.0)THEN 1557 : GOTO 4112 1558 : ELSE 1559 : C Polygone 1560 : IFIN=IDEP+2*IPT1.NUM(/1)-2 1561 : IFIN2=IFIN -2 1562 : ENDIF 1563 : ENDIF 1564 : 4112 CONTINUE 1565 : * IFIN=IDEP+2*LPL(K)-2 1566 : DO 4115 I=1,IPT1.NUM(/2) 1567 : IF (IDEFCO.EQ.1.AND.IPT1.ICOLOR(I).NE.IICOL) GOTO 4115 1568 : XG=0. 1569 : YG=0. 1570 : ZG=0. 1571 : ZN=0. 1572 : N=IPT1.NUM(/1) 1573 : DO 4116 J=1,N 1574 : XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I))) 1575 : YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I))) 1576 : ZG=ZG+XPROJ(3,ICPR(IPT1.NUM(J,I))) 1577 : 4116 CONTINUE 1578 : XG=XG/N 1579 : YG=YG/N 1580 : ZG=ZG/N 1581 : I3=0 1582 : IF (ICOLE.NE.IPT1.ICOLOR(I)) THEN 1583 : ICOLE=IPT1.ICOLOR(I) 1583 : CALL CHCOUL(ICOLE) 1584 : ENDIF 1585 : ITR=1 1586 : ILTEL=LTEL(1,K) 1587 : IF (ILTEL.NE.0) THEN 1588 : DO 4117 IF=1,ILTEL 1589 : ITR=0 1590 : ILTAD=LTEL(2,K) 1591 : ITYP=LDEL(1,ILTAD+IF-1) 1592 : IAD=LDEL(2,ILTAD+IF-1) 1593 : DO 4118 J=1,KDFAC(1,ITYP) 1594 : I1=ICPR(IPT1.NUM(LFAC(IAD+J-1),I)) 1595 : XR=XG+(XPROJ(1,I1)-XG)*XECLAT 1596 : YR=YG+(XPROJ(2,I1)-YG)*XECLAT 1597 : ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT 1598 : ITR=ITR+1 1599 : XTR(ITR)=XR 1600 : YTR(ITR)=YR 1601 : ZTR(ITR)=ZR 1602 : 4118 CONTINUE 1603 : ITR=ITR+1 1604 : XTR(ITR)=XTR(1) 1605 : YTR(ITR)=YTR(1) 1606 : ZTR(ITR)=ZTR(1) 1607 : IF (IFADES.EQ.0) THEN 1607 : CALL POLRL(ITR,XTR,YTR,ZTR) 1608 : ELSE 1608 : CALL TRFACE(ITR,XTR,YTR,ZTR,ZN,ICOLE,IEFF) 1608 : CALL CHCOUL(IDNOIR) 1608 : CALL POLRL(ITR,XTR,YTR,ZTR) 1608 : CALL CHCOUL(ICOLE) 1609 : ENDIF 1610 : ITR=0 1611 : 4117 CONTINUE 1612 : ELSE 1613 : DO 4114 J=IDEP,IFIN,2 1614 : IF (J.LE.IFIN2) THEN 1615 : I1=ICPR(IPT1.NUM(KSEGM(J),I)) 1616 : I2=ICPR(IPT1.NUM(KSEGM(J+1),I)) 1617 : ELSE 1618 : I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I)) 1619 : I2=ICPR(IPT1.NUM(KSEGM(1),I)) 1620 : ENDIF 1621 : XR=XG+(XPROJ(1,I1)-XG)*XECLAT 1622 : YR=YG+(XPROJ(2,I1)-YG)*XECLAT 1623 : ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT 1624 : IF (I1.NE.I3) THEN 1625 : if (ifades.eq.0) then 1625 : IF (ITR.NE.1) call POLRL(ITR,XTR,YTR,ZTR) 1626 : else 1626 : IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff) 1627 : endif 1628 : ITR=1 1629 : XTR(1)=XR 1630 : YTR(1)=YR 1631 : ZTR(1)=ZR 1632 : ENDIF 1633 : XR=XG+(XPROJ(1,I2)-XG)*XECLAT 1634 : YR=YG+(XPROJ(2,I2)-YG)*XECLAT 1635 : ZR=ZG+(XPROJ(3,I2)-ZG)*XECLAT 1636 : ITR=ITR+1 1637 : XTR(ITR)=XR 1638 : YTR(ITR)=YR 1639 : ZTR(ITR)=ZR 1640 : I3=I2 1641 : 4114 CONTINUE 1642 : if (ifades.eq.0) then 1642 : IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR) 1643 : else 1643 : IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff) 1644 : endif 1645 : ITR=1 1646 : ENDIF 1647 : 4115 CONTINUE 1648 : IF (LISOUS(/1).NE.0) SEGDES IPT1 1649 : 4111 CONTINUE 1650 : SEGDES MELEME 1651 : 4202 CONTINUE 1652 : 1653 : *---------------------------------------------------------- 1654 : * TRAITEMENT DES PARAMETRES TELS QUE NOEUD,QUALI,... 1655 : * (AVANT AFFICHAGE) 1656 : *---------------------------------------------------------- 1657 : IF (IQUALI.EQ.0) GOTO 500 1658 : SEGACT XPROJ,IVU,ICPR 1659 : PAS=(X2-X1)/(XMA-XMI) 1659 : CALL INSEGT(3,IRESU) 1660 : C ON MET LES NOMS LA OU ON PEUT 1661 : if(nbesc.ne.0) segact ipiloc 1662 : DO 501 IOB=1,LMNNOM 1663 : * IGNORER LES OBJETS TEMPORAIRES OU INVALIDES 1664 : ICOLE=0 1665 : IF (INOOB2(IOB).NE.'MAILLAGE') GOTO 511 1666 : IPVH=INOOB1(IOB) 1667 : IDEBCH=IPCHAR(IPVH) 1668 : IFINCH=IPCHAR(IPVH+1)-1 1669 : TXT= ICHARA(IDEBCH:IFINCH) 1670 : IF (TXT(1:1).EQ.'#') GOTO 501 1671 : IF (TXT(1:1).EQ.' ') GOTO 501 1672 : IPT4=IOUEP2(IOB) 1673 : IF (IPT4.EQ.0) GOTO 501 1674 : SEGACT IPT4 1675 : XP=0 1676 : YP=0 1677 : ZP=0 1678 : NP=0 1679 : IPT5=IPT4 1680 : DO 503 ISB=1,MAX(1,IPT4.LISOUS(/1)) 1681 : IF (IPT4.LISOUS(/1).NE.0) THEN 1682 : IPT5=IPT4.LISOUS(ISB) 1683 : SEGACT IPT5 1684 : ENDIF 1685 : *PM NBCOUL-1 au lieu de 7 1686 : DO 507 I=1,NBCOUL-1 1687 : ITEST(I)=0 1688 : 507 CONTINUE 1689 : DO 504 J=1,IPT5.NUM(/2) 1690 : IF (IPT5.ICOLOR(J).NE.0) THEN 1691 : ITEST(IPT5.ICOLOR(J))=1 1692 : ELSE 1693 : * ITEST(7)=1 1694 : ENDIF 1695 : DO 5041 I=1,IPT5.NUM(/1) 1696 : K=ICPR(IPT5.NUM(I,J)) 1697 : IF (K.EQ.0) GOTO 505 1698 : IF (IVU(K).LE.0) GOTO 5041 1699 : NP=NP+1 1700 : XP=XP+XPROJ(1,K) 1701 : YP=YP+XPROJ(2,K) 1702 : ZP=ZP+XPROJ(3,K) 1703 : 5041 CONTINUE 1704 : 504 CONTINUE 1705 : IF (IPT4.LISOUS(/1).NE.0) SEGDES IPT5 1706 : 503 CONTINUE 1707 : SEGDES IPT4 1708 : IF (NP.EQ.0) GOTO 501 1709 : XP=XP/NP 1710 : YP=YP/NP 1711 : ZP=ZP/NP 1712 : C IF (XP.LT.XMI.OR.XP.GT.XMA.OR.YP.LT.YMI.OR.YP.GT.YMA) GOTO 501 1713 : ICOLE=0 1714 : *PM NBCOUL-1 au lieu de 7 1715 : * couleur avec melange eventuel si plusieurs 1716 : DO 508 I=1,NBCOUL-1 1717 : IF (ITEST(I).EQ.1) THEN 1718 : IF (ICOLE.EQ.0) THEN 1719 : ICOLE=I 1720 : ELSE 1721 : ICOLE=ITABM(ICOLE,I) 1722 : ENDIF 1723 : ENDIF 1724 : 508 CONTINUE 1725 : IF (IDEFCO.EQ.1.AND.ICOLE.NE.IICOL) GOTO 501 1725 : CALL CHCOUL(ICOLE) 1726 : XP=PAS*(XP-XMI)+X1 1727 : YP=PAS*(YP-YMI)+Y1 1728 : ZP=PAS*(ZP-ZMI)+ZMI 1729 : * TXT= INOOB1(IOB) 1729 : CALL TRLABL(XP,YP,ZP,TXT,8,0.15) 1730 : GOTO 501 1731 : 505 CONTINUE 1732 : SEGDES IPT4,IPT5 1733 : 511 CONTINUE 1734 : C AU TOUR DES POINTS NOMMES 1735 : IF (INOOB2(IOB).NE.'POINT ') GOTO 501 1736 : IF (IOUEP2(IOB).EQ.0) GOTO 501 1737 : K=ICPR(IOUEP2(IOB)) 1738 : IF (K.EQ.0) GOTO 501 1739 : IF (IVU(K).LE.0) GOTO 501 1740 : C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 501 1741 : C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 501 1742 : ITRUC=0 1743 : IF (IDEFCO.EQ.1) THEN 1744 : 512 DO 509 I=1,NBCONR 1745 : *PM ?????????? pb si codage KON en binaire ??????????? 1746 : IF (KON(2,I,K).EQ.IICOL) THEN 1747 : ITRUC=1 1748 : GOTO 510 1749 : ENDIF 1750 : 509 CONTINUE 1751 : IF (KON(1,NBCON,K).NE.0) THEN 1752 : K=KON(1,NBCON,K) 1753 : GOTO 512 1754 : ENDIF 1755 : ELSE 1756 : ITRUC=1 1757 : ENDIF 1758 : 510 IF (ITRUC.EQ.1) THEN 1758 : CALL CHCOUL(0) 1759 : XP=XPROJ(1,K) 1760 : YP=XPROJ(2,K) 1761 : ZP=XPROJ(3,K) 1762 : XP=PAS*(XP-XMI)+X1 1763 : YP=PAS*(YP-YMI)+Y1 1764 : ZP=PAS*(ZP-ZMI)+ZMI 1765 : IPVH=INOOB1(IOB) 1766 : IDEBCH=IPCHAR(IPVH) 1767 : IFINCH=IPCHAR(IPVH+1)-1 1768 : TXT= ICHARA(IDEBCH:IFINCH) 1768 : CALL TRLABL(XP,YP,ZP,TXT,8,0.15) 1769 : ENDIF 1770 : 501 CONTINUE 1771 : if(nbesc.ne.0) segdes ipiloc 1772 : IF (IRESU.EQ.3) GOTO 6101 1773 : 500 IF (INUMNO.EQ.0) GOTO 531 1774 : SEGACT XPROJ,IVU,ICPR 1775 : PAS=(X2-X1)/(XMA-XMI) 1775 : CALL INSEGT(4,IRESU) 1776 : C INDICATION DES NUMEROS DE NOEUDS 1776 : CALL CHCOUL(0) 1777 : DO 530 I=1,NBPTS 1778 : K=ICPR(I) 1779 : IF (K.EQ.0) GOTO 530 1780 : IF (IVU(K).LE.0) GOTO 530 1781 : C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 530 1782 : C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 530 1783 : ITRUC=0 1784 : IF (IDEFCO.EQ.1) THEN 1785 : 521 DO 519 J=1,NBCONR 1786 : *PM ?????????? pb si codage KON en binaire ??????????? 1787 : IF (KON(2,J,K).EQ.IICOL) THEN 1788 : ITRUC=1 1789 : GOTO 520 1790 : ENDIF 1791 : 519 CONTINUE 1792 : IF (KON(1,NBCON,K).NE.0) THEN 1793 : K=KON(1,NBCON,K) 1794 : GOTO 521 1795 : ENDIF 1796 : ELSE 1797 : ITRUC=1 1798 : ENDIF 1799 : 520 IF (ITRUC.EQ.1) THEN 1800 : IF (I.LT.10) THEN 1801 : FMTX='(I1,7X)' 1802 : ELSEIF (I.LT.100) THEN 1803 : FMTX='(I2,6X)' 1804 : ELSEIF (I.LT.1000) THEN 1805 : FMTX='(I3,5X)' 1806 : ELSEIF (I.LT.10000) THEN 1807 : FMTX='(I4,4X)' 1808 : ELSEIF (I.LT.100000) THEN 1809 : FMTX='(I5,3X)' 1810 : ELSEIF (I.LT.1000000) THEN 1811 : FMTX='(I6,2X)' 1812 : ENDIF 1813 : WRITE (TXT,FMT=FMTX) I 1814 : XP=XPROJ(1,K) 1815 : YP=XPROJ(2,K) 1816 : ZP=XPROJ(3,K) 1817 : XP=PAS*(XP-XMI)+X1 1818 : YP=PAS*(YP-YMI)+Y1 1819 : ZP=PAS*(ZP-ZMI)+ZMI 1819 : CALL TRLABL(XP,YP,ZP,TXT,8,0.15) 1820 : ENDIF 1821 : 530 CONTINUE 1822 : IF (IRESU.EQ.4) GOTO 6101 1823 : 531 CONTINUE 1824 : *+++* 1825 : IF (LABCO2.EQ.0) GOTO 538 1826 : MVECTS=MVECTE 1827 : MVECTE=LABCO2(3,IDEF) 1828 : IF (MVECTE.EQ.0) GOTO 538 1829 : SEGACT XPROJ,IVU,ICPR 1830 : 1831 : C TRACE DES VECTEURS SI IL Y A LIEU 1832 : SEGACT MVECTE 1833 : NVEC=NOCOUL(/1) 1834 : KABCO2=LABCO2(1,IDEF) 1835 : KXPRO2=LABCO2(2,IDEF) 1836 : DO 541 IVEC=1,NVEC 1837 : * Mots reserves : contraintes principales / fissures 1837 : CALL PLACE(MOVE,6,IPLA,NOCOVE(IVEC,1)) 1838 : IF (IPLA.EQ.0) THEN 1839 : * Cas classique des vecteurs 1840 : *PM NLEGMX au lieu de 8 1841 : IF (NVECL.LT.NLEGMX) THEN 1842 : IFLE = 0 1843 : NVECL=NVECL+1 1844 : VAMPF(NVECL)=REAL(AMPF(IVEC)) 1845 : IF (VAMPF(NVECL).LT.0) IFLE = -1 1846 : NVCOL(NVECL)=NOCOUL(IVEC) 1847 : NVLEG(1,NVECL)=NOCOVE(IVEC,1) 1848 : cbp petit ajout pour eviter pb si vecteurs créés depuis mchaml 1849 : NVLEG(2,NVECL)=' ' 1850 : NVLEG(3,NVECL)=' ' 1851 : IDVECT=NOCOVE(/3) 1852 : IF(IDVECT.GT.1) THEN 1853 : NVLEG(2,NVECL)=NOCOVE(IVEC,2) 1854 : IF (IDIM.EQ.3) NVLEG(3,NVECL)=NOCOVE(IVEC,3) 1855 : ENDIF 1856 : cbp fin petit ajout 1857 : ENDIF 1858 : ELSE 1859 : * Cas des contraintes principales 1860 : IF (IPLA.LE.3) IFLE = 1 1861 : * Cas des fissures 1862 : IF (IPLA.GT.3) IFLE = 2 1863 : IF (IFLE.EQ.1.AND.NOCOVE(2,1).EQ.NOCOVE(1,1)) THEN 1864 : NVECL = 1 1865 : VAMPF(1)=REAL(AMPF(1)) 1866 : NVCOL(1)=NOCOUL(1) 1867 : NVLEG(1,1)=NOCOVE(1,1) 1868 : ELSE 1869 : NVECL = 2 1870 : VAMPF(1)=REAL(AMPF(1)) 1871 : NVCOL(1)=NOCOUL(1) 1872 : NVLEG(1,1)=NOCOVE(1,1) 1873 : VAMPF(2)=REAL(AMPF(2)) 1874 : NVCOL(2)=NOCOUL(2) 1875 : NVLEG(1,2)=NOCOVE(2,1) 1876 : IF (IDIM.EQ.3) THEN 1877 : NVECL = 3 1878 : VAMPF(3)=REAL(AMPF(3)) 1879 : NVCOL(3)=NOCOUL(3) 1880 : NVLEG(1,3)=NOCOVE(3,1) 1881 : ENDIF 1882 : ENDIF 1883 : ENDIF 1884 : XPRO2=KXPRO2(IVEC) 1885 : ICOR2=KABCO2(2,IVEC) 1886 : SEGACT XPRO2,ICOR2,XPROJ,IVU,ICPR 1887 : INVCOU=NOCOUL(IVEC) 1887 : CALL CHCOUL(INVCOU) 1888 : DO 540 I=1,NBPTS 1889 : K=ICPR(I) 1890 : IF (K.EQ.0) GOTO 540 1891 : IF (ICOR2(K).EQ.0) GOTO 540 1892 : IF (IVU(K).LE.0) GOTO 540 1893 : IF (IFLE.EQ.-1) THEN 1894 : * Fleches pointant vers les points 1895 : UX=XPROJ(1,K)-XPRO2(1,K) 1896 : UY=XPROJ(2,K)-XPRO2(2,K) 1897 : UZ=XPROJ(3,K)-XPRO2(3,K) 1898 : XTR(1)=XPRO2(1,K) 1899 : YTR(1)=XPRO2(2,K) 1900 : ZTR(1)=XPRO2(3,K) 1901 : XTR(2)=XPROJ(1,K)-UX/10. 1902 : YTR(2)=XPROJ(2,K)-UY/10. 1903 : ZTR(2)=XPROJ(3,K)-UZ/10. 1904 : U1=XPROJ(1,K)-UX/3-UY/5 1905 : V1=XPROJ(2,K)-UY/3+UX/5 1906 : W1=XPROJ(3,K) 1907 : XTR(3)=U1 1908 : YTR(3)=V1 1909 : ZTR(3)=W1 1910 : XTR(4)=XPROJ(1,K) 1911 : YTR(4)=XPROJ(2,K) 1912 : ZTR(4)=XPROJ(3,K) 1913 : U1=XPROJ(1,K)-UX/3+UY/5 1914 : V1=XPROJ(2,K)-UY/3-UX/5 1915 : W1=XPROJ(3,K) 1916 : XTR(5)=U1 1917 : YTR(5)=V1 1918 : ZTR(5)=W1 1919 : XTR(6)=XPROJ(1,K)-UX/10. 1920 : YTR(6)=XPROJ(2,K)-UY/10. 1921 : ZTR(6)=XPROJ(3,K) 1921 : CALL POLRL(6,XTR,YTR,ZTR) 1922 : ELSE IF (IFLE.EQ.0) THEN 1923 : * Fleches partant des points 1924 : 1925 : XTR(1)=XPROJ(1,K) 1926 : YTR(1)=XPROJ(2,K) 1927 : ZTR(1)=XPROJ(3,K) 1928 : UX=XPRO2(1,K)-XPROJ(1,K) 1929 : UY=XPRO2(2,K)-XPROJ(2,K) 1930 : UZ=XPRO2(3,K)-XPROJ(3,K) 1931 : XTR(2)=XPRO2(1,K)-UX/10. 1932 : YTR(2)=XPRO2(2,K)-UY/10. 1933 : ZTR(2)=XPRO2(3,K) 1934 : U1=XPRO2(1,K)-UX/3-UY/5 1935 : V1=XPRO2(2,K)-UY/3+UX/5 1936 : W1=XPRO2(3,K) 1937 : XTR(3)=U1 1938 : YTR(3)=V1 1939 : ZTR(3)=W1 1940 : XTR(4)=XPRO2(1,K) 1941 : YTR(4)=XPRO2(2,K) 1942 : ZTR(4)=XPRO2(3,K) 1943 : U1=XPRO2(1,K)-UX/3+UY/5 1944 : V1=XPRO2(2,K)-UY/3-UX/5 1945 : W1=XPRO2(3,K) 1946 : XTR(5)=U1 1947 : YTR(5)=V1 1948 : ZTR(5)=W1 1949 : XTR(6)=XPRO2(1,K)-UX/10. 1950 : YTR(6)=XPRO2(2,K)-UY/10. 1951 : ZTR(6)=XPRO2(3,K) 1951 : CALL POLRL(6,XTR,YTR,ZTR) 1952 : ELSE IF (IFLE.EQ.1) THEN 1953 : * contraintes principales 1954 : IF (ICOR2(K).EQ.1) THEN 1955 : NTR = 6 1956 : XTR(1) = XPROJ(1,K) 1957 : YTR(1) = XPROJ(2,K) 1958 : ZTR(1) = XPROJ(3,K) 1959 : UX = XPRO2(1,K) - XPROJ(1,K) 1960 : UY = XPRO2(2,K) - XPROJ(2,K) 1961 : UZ = XPRO2(3,K) - XPROJ(3,K) 1962 : XTR(2) = XPRO2(1,K) - UX/10 1963 : YTR(2) = XPRO2(2,K) - UY/10 1964 : ZTR(2) = XPRO2(3,K) 1965 : XTR(3) = XPRO2(1,K) - UX/3 - UY/5 1966 : YTR(3) = XPRO2(2,K) - UY/3 + UX/5 1967 : ZTR(3) = XPRO2(3,K) 1968 : XTR(4) = XPRO2(1,K) 1969 : YTR(4) = XPRO2(2,K) 1970 : ZTR(4) = XPRO2(3,K) 1971 : XTR(5) = XPRO2(1,K) - UX/3 + UY/5 1972 : YTR(5) = XPRO2(2,K) - UY/3 - UX/5 1973 : ZTR(5) = XPRO2(3,K) 1974 : XTR(6) = XPRO2(1,K) - UX/10. 1975 : YTR(6) = XPRO2(2,K) - UY/10. 1976 : ZTR(6) = XPRO2(3,K) 1976 : CALL POLRL(NTR,XTR,YTR,ZTR) 1977 : ELSE 1978 : NTR = 6 1979 : XTR(1) = XPROJ(1,K) 1980 : YTR(1) = XPROJ(2,K) 1981 : ZTR(1) = XPROJ(3,K) 1982 : XTR(2) = XPRO2(1,K) 1983 : YTR(2) = XPRO2(2,K) 1984 : ZTR(2) = XPRO2(3,K) 1985 : UX = XPRO2(1,K) - XPROJ(1,K) 1986 : UY = XPRO2(2,K) - XPROJ(2,K) 1987 : UZ = XPRO2(3,K) - XPROJ(3,K) 1988 : XTR(3) = XPRO2(1,K) + UX/3 + UY/5 1989 : YTR(3) = XPRO2(2,K) + UY/3 - UX/5 1990 : ZTR(3) = XPRO2(3,K) 1991 : XTR(4) = XPRO2(1,K) + UX/10 1992 : YTR(4) = XPRO2(2,K) + UY/10 1993 : ZTR(4) = XPRO2(3,K) 1994 : XTR(5) = XPRO2(1,K) + UX/3 - UY/5 1995 : YTR(5) = XPRO2(2,K) + UY/3 + UX/5 1996 : ZTR(5) = XPRO2(3,K) 1997 : XTR(6) = XPRO2(1,K) 1998 : YTR(6) = XPRO2(2,K) 1999 : ZTR(6) = XPRO2(3,K) 1999 : CALL POLRL(NTR,XTR,YTR,ZTR) 2000 : ENDIF 2001 : ELSE IF (IFLE.EQ.2) THEN 2002 : * fissures 2003 : IF (ICOR2(K).EQ.-1) GOTO 540 2004 : NTR = 2 2005 : XTR(1) = XPROJ(1,K) 2006 : YTR(1) = XPROJ(2,K) 2007 : ZTR(1) = XPROJ(3,K) 2008 : XTR(2) = XPRO2(1,K) 2009 : YTR(2) = XPRO2(2,K) 2010 : ZTR(2) = XPRO2(3,K) 2010 : CALL POLRL(NTR,XTR,YTR,ZTR) 2011 : ENDIF 2012 : 540 CONTINUE 2013 : SEGSUP XPRO2,ICOR2 2014 : 541 CONTINUE 2015 : SEGSUP KXPRO2,KABCO2 2016 : MVECTE = MVECTS 2017 : 538 CONTINUE 2018 : IF (INUMEL.EQ.0) GOTO 532 2019 : SEGACT XPROJ,IVU,ICPR 2020 : PAS=(X2-X1)/(XMA-XMI) 2020 : CALL INSEGT(5,IRESU) 2021 : SEGACT MELEME 2022 : IPT1=MELEME 2023 : IF (MCOUP.NE.0) GOTO 537 2024 : DO 534 II=1,MAX(1,LISOUS(/1)) 2025 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(II) 2026 : SEGACT IPT1 2027 : NBNN=IPT1.NUM(/1) 2028 : NBELEM=IPT1.NUM(/2) 2029 : DO 535 L=1,NBELEM 2030 : XG=0. 2031 : YG=0. 2032 : ZG=0. 2033 : NG=0 2034 : DO 536 N=1,NBNN 2035 : I=ICPR(IPT1.NUM(N,L)) 2036 : IF (IVU(I).LE.0) GOTO 536 2037 : XG=XG+XPROJ(1,I) 2038 : YG=YG+XPROJ(2,I) 2039 : ZG=ZG+XPROJ(3,I) 2040 : NG=NG+1 2041 : 536 CONTINUE 2042 : IF (NG.EQ.0) GOTO 535 2043 : XG=XG/NG 2044 : YG=YG/NG 2045 : ZG=ZG/NG 2046 : C IF (XG.LT.XMI.OR.XG.GT.XMA.OR.YG.LT.YMI.OR.YG.GT.YMA) GOTO 535 2047 : INVCOU=IPT1.ICOLOR(L) 2048 : * IF (INVCOU.EQ.0) INVCOU=IDCOUL 2049 : IF (IDEFCO.EQ.1.AND.INVCOU.NE.IICOL) GOTO 535 2049 : CALL CHCOUL(INVCOU) 2050 : IF (L.LT.10) THEN 2051 : FMTX='(I1,7X)' 2052 : ELSEIF (L.LT.100) THEN 2053 : FMTX='(I2,6X)' 2054 : ELSEIF (L.LT.1000) THEN 2055 : FMTX='(I3,5X)' 2056 : ELSEIF (L.LT.10000) THEN 2057 : FMTX='(I4,4X)' 2058 : ELSEIF (L.LT.100000) THEN 2059 : FMTX='(I5,3X)' 2060 : ELSEIF (L.LT.1000000) THEN 2061 : FMTX='(I6,2X)' 2062 : ENDIF 2063 : WRITE (TXT,FMT=FMTX) L 2064 : XG=PAS*(XG-XMI)+X1 2065 : YG=PAS*(YG-YMI)+Y1 2066 : ZG=PAS*(ZG-ZMI)+ZMI 2066 : CALL TRLABL(XG,YG,ZG,TXT,8,0.15) 2067 : 535 CONTINUE 2068 : IF (LISOUS(/1).NE.0) SEGDES IPT1 2069 : 534 CONTINUE 2070 : 537 SEGDES MELEME 2071 : IF (IRESU.EQ.5.OR.IRESU.EQ.7) GOTO 6101 2072 : 532 CONTINUE 2073 : IF (IDEFOR.EQ.0) GOTO 6101 2074 : SEGSUP KON,XPROJ,ICPR,IVU 2075 : IF (XPRO2.NE.0) SEGSUP XPRO2 2076 : IF (MCOUP.NE.0) THEN 2077 : C NETTOYAGE APRES COUPE 2078 : * SEGSUP MCOUP 2079 : SEGACT MCOORD*MOD 2080 : * SEGADJ MCOORD 2081 : * SEGACT MELEME 2082 : * DO 8801 IO=1,LISOUS(/1) 2083 : ** IPT1=LISOUS(IO) 2084 : * SEGSUP IPT1 2085 : * 8801 CONTINUE 2086 : * SEGSUP MELEME 2087 : ENDIF 2088 : GOTO 6099 2089 : C<<<< FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS <<<<<<<<<<<<<<<<<<<<<< 2090 : 2091 : 2092 : C---- POINT D'ARRIVEE EN FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS --- 2093 : 6100 CONTINUE 2094 : IDEFS=IDEFOR 2095 : IDEFOR=0 2095 : IF (IANIM.NE.0) CALL TRIMAG(NDEF+1) 2096 : IF (KABEL.NE.0) SEGSUP KABEL 2097 : IF (KABEL2.NE.0) SEGSUP KABEL2 2098 : IF (KABCPR.NE.0) SEGSUP KABCPR 2099 : IF (KABCP2.NE.0) SEGSUP KABCP2 2100 : SEGSUP KABCOR 2101 : IF (KABCO3.NE.0) SEGSUP KABCO3 2102 : IF (LABCO2.NE.0) SEGSUP LABCO2 2103 : IF (LABCO3.NE.0) SEGSUP LABCO3 2104 : 6101 CONTINUE 2104 : CALL MAJSEG(1,IRESU,IQUALI,INUMNO,INUMEL) 2105 : IF (ZCHAM) THEN 2106 : * ZCHAM=.TRUE. 2107 : SEGACT MCHPOI,icpr,vcpcha 2108 : do ibc=1,ipchp(/1) 2109 : msoupo=ipchp(ibc) 2110 : segact msoupo 2111 : do ibcn=1,nocomp(/2) 2112 : if(compch(lcomp).eq.nocomp(ibcn)) go to 6108 2113 : enddo 2114 : go to 6107 2115 : 6108 continue 2116 : IPT6=IGEOC 2117 : SEGACT IPT6 2118 : MPOVAL=IPOVAL 2119 : SEGACT MPOVAL 2120 : do I=1, IPT6.NUM(/2) 2121 : IJ=IPT6.NUM(1,I) 2122 : ijj=icpr(ij) 2123 : WRITE(VALCH,FMT='(E10.3)') vcpcha(ij) 2123 : CALL TRLABL(XPROJ(1,IJj),XPROJ(2,IJj),0., 2124 : $ VALCH,LEN(VALCH),0.15) 2125 : enddo 2126 : segdes ipt6,mpoval 2127 : 6107 continue 2128 : segdes msoupo 2129 : enddo 2130 : segdes mchpoi,icpr,vcpcha 2131 : ENDIF 2132 : * BERTIN : fin affichage CHAMPOIN 2133 : IF (INWDS.AND.VALEUR) THEN 2134 : * AFFICHAGE DES LABELS DES ISOVALEURS 2134 : CALL FVALIS(1,IRESU,NHAUT,NISO) 2135 : iresu=3 2135 : CALL INSEGT(7,iresu) 2135 : CALL CHCOUL(0) 2136 : NHAUT=NHAUT+INT(YHAUT) 2137 : 2138 : NDEC=0 2139 : IF (NISO.NE.0) THEN 2140 : * Legende des isovaleurs 2141 : IF(TXISO.NE.' ') VALISO=TXISO 2142 : IF (NCOMP.NE.0) VALISO=COMPCH(LCOMP)(1:12) 2143 : LVS=LONG(VALISO) 2143 : CALL TRLABL(XHAUT+0.1,FLOAT(NHAUT+2),0.,VALISO(1:LVS),LVS,0.17) 2144 : * min et max 2145 : WRITE (ZONE,FMT='(1PE9.2)') VCHMIN 2145 : CALL TRLABL(XHAUT+0.,FLOAT(NHAUT+1),0.,'>'//ZONE,10,0.17) 2146 : 2146 : IF (ZDATE) CALL TRLABL(-1.4,FLOAT(NHAUT-50),0.,BUFFER,26, 2147 : $ 0.17) 2148 : WRITE (ZONE,FMT='(1PE9.2)') VCHMAX 2148 : CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'<'//ZONE,10,0.17) 2149 : * NISO=MIN(15,NISO) 2150 : * NDEC : amplitude verticale de la gamme d'isovaleurs 2151 : NDEC = 25 2152 : PDEC = REAL(NDEC) 2153 : PDDEC= PDEC/NISO 2154 : cBP pour espacer les legendes avec VING DIX ou CINQ labels maxi 2155 : XDEC=0.98 2156 : if(NDEC2.eq.1) XDEC=XDEC*25./21. 2157 : if(NDEC2.eq.2) XDEC=XDEC*25./11. 2158 : if(NDEC2.eq.3) XDEC=XDEC*25./6. 2159 : FAIT = -1 2160 : *PM NHAUT= NHAUT 2161 : NBAS = NHAUT - 1 - NDEC 2162 : DO 6102 I=1,NISO 2163 : PYB = NBAS + ((I-1)*PDDEC) 2164 : IF (ISOTYP.NE.0) THEN 2165 : * petit carre colore 2166 : PX(1)=XHAUT+0. 2167 : PX(2)=XHAUT+0.09 2168 : PX(3)=XHAUT+0.09 2169 : PX(4)=XHAUT+0. 2170 : PY(1)=PYB 2171 : PY(2)=PYB 2172 : PY(3)=PYB + PDDEC 2173 : PY(4)=PYB + PDDEC 2174 : * si moins de 16 isov., on prend une couleur 2175 : * correspondante sur deux (NISO<8) ou sur une (NISO>=8) 2176 : IF (NISO.LT.16) THEN 2176 : c CALL TRAISO(4,PX,PY,ICOTAB(I*(2-NISO/8))) 2176 : CALL TRAISO(4,PX,PY,ICOTAB(ISOTAB(I,NISO))) 2177 : ELSE 2177 : CALL TRAISO(4,PX,PY,I) 2178 : ENDIF 2179 : IF (I*PDDEC-FAIT.LT. XDEC ) GOTO 6102 2180 : * valeur seuil pour l'affichage de la legende isovaleur 2181 : IF (I.GT.1) THEN 2182 : WRITE (ZONE,FMT='(1PG9.2)') VCHC(I-1) 2182 : CALL CHCOUL(0) 2182 : CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17) 2183 : ENDIF 2184 : FAIT=I*PDDEC 2185 : ELSE 2186 : * lettre coloree 2187 : IF (NISO.LT.13) THEN 2187 : * CALL CHCOUL(ICOTAB(I*(2-NISO/8))) 2187 : CALL CHCOUL(ICOTAB(ISOTA0(I,NISO))) 2188 : ELSE 2188 : *sg CALL CHCOUL(I) 2188 : CALL CHCOUL(ICOTAB(MOD(I,12)+1)) 2189 : ENDIF 2190 : IF (I*PDDEC-FAIT.LT. 0.98 ) GOTO 6102 2190 : CALL TRLABL(XHAUT+0.002,PYB,0.,ABCDEF(I:I),1,0.17) 2191 : * valeur seuil 2192 : WRITE (ZONE,FMT='(1PG9.2)') VCHC(I) 2192 : CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17) 2193 : FAIT=I*PDDEC 2194 : ENDIF 2195 : 6102 CONTINUE 2196 : ELSE IF (KDEFOR.NE.0) THEN 2196 : CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'AMPLITUDE',9,0.17) 2197 : *PM NDEFMX au lieu de 7 2198 : NDEF=MIN(NDEF,NDEFMX) 2199 : NBAS = NHAUT - 1 - NDEF 2200 : DO 6103 I=1,NDEF 2200 : CALL CHCOUL(ICHL(I)) 2201 : xxxx= ampimp 2202 : if(ampimp.ge.xsgran/2.)xxxx = vchc(I) 2203 : WRITE (ZONE,FMT='(1PG9.2)') xxxx 2203 : CALL TRLABL(XHAUT+0.,FLOAT(NBAS+I),0.,ZONE,9,0.17) 2204 : 6103 CONTINUE 2205 : ENDIF 2206 : IF (NISO.NE.0.AND.KDEFOR.NE.0) THEN 2206 : CALL CHCOUL(0) 2206 : CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-3),0.,'AMPLITUDE',9,0.17) 2206 : CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-4),0.,'DEFORMEE ',9,0.17) 2207 : WRITE (ZONE,FMT='(1PG9.2)') SIAMPL 2207 : CALL TRLABL(0.,FLOAT(NHAUT - 6 - NDEC),0.,ZONE,9,0.17) 2208 : ENDIF 2209 : IF (NVECL.NE.0) THEN 2209 : CALL TRBOX(0.75,0.75) 2209 : CALL CHCOUL(0) 2210 : *+++* 2210 : CALL TRLABL(-0.1,FLOAT(NHAUT-NDEC-8),0., 2211 : & 'COMPOSANTES',11,0.17) 2212 : IF (IFLE.NE.0) THEN 2213 : IF (IFLE.EQ.1) THEN 2213 : CALL TRLABL(-0.1,NHAUT-NDEC-8.75,0., 2214 : & 'CONTRAINTES',11,0.17) 2215 : ELSE 2215 : CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'FISSURES',8,0.17) 2216 : ENDIF 2217 : NBAS = NHAUT - 10 - NDEC - NVECL 2218 : DO I=1,NVECL 2218 : CALL CHCOUL(NVCOL(I)) 2219 : ZONE=NVLEG(1,I) 2219 : CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,4,0.17) 2220 : ENDDO 2221 : ELSE 2221 : CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'VECTEURS',8,0.17) 2222 : NBAS = NHAUT - 10 - NDEC - NVECL 2223 : DO 6104 I=1,NVECL 2223 : CALL CHCOUL(NVCOL(I)) 2224 : IF (IDIM.EQ.2) ZONE=NVLEG(1,I)//NVLEG(2,I) 2225 : IF (IDIM.EQ.3) ZONE=NVLEG(1,I)//NVLEG(2,I)//NVLEG(3,I) 2225 : CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,12,0.17) 2226 : 6104 CONTINUE 2227 : ENDIF 2228 : ENDIF 2229 : INWDS2=INWDS 2230 : INWDS=.FALSE. 2230 : CALL FVALIS(0,IRESU,NHAUT,NISO) 2231 : ENDIF 2232 : 2233 : 2234 : *---------------------------------------------------------- 2235 : * 2236 : * POST TRAITEMENT DE L'AFFICHAGE : ZOOM,NOM,IMPRESSION ... 2237 : * 2238 : *---------------------------------------------------------- 2239 : 2240 : C 2241 : 6105 CONTINUE 2242 : C AFFICHAGE DES CLES GRAPHIQUES 2243 : C AFFICHAGE DES CLES GRAPHIQUES 2244 : NCASE=10 2245 : LLONG=13 2246 : LEGEND(1)=' Fin trace ' 2247 : LEGEND(2)=' Zoom/Pan' 2248 : LEGEND(3)=' Rotation' 2249 : LEGEND(4)=' Coupe ' 2250 : LEGEND(5)=' Valeur' 2251 : LEGEND(6)='Qualification' 2252 : LEGEND(7)=' Noeuds' 2253 : LEGEND(8)=' Elements' 2254 : LEGEND(9)=' Animation' 2255 : * attention dans xtrini on teste la chaine " Animation" 2256 : LEGEND(10)=' Options' 2257 : 2258 : if (idim.ne.3) then 2259 : legend(3)=' ' 2260 : legend(4)=' ' 2261 : endif 2262 : IF (NISO.NE.0.OR.NDEF.NE.0.OR.NVECL.NE.0) THEN 2263 : LEGEND(6)=' ' 2264 : LEGEND(7)=' ' 2265 : LEGEND(8)=' ' 2266 : IF (KDEFOR.NE.0.OR.IVEC.NE.0) LEGEND(5)=' ' 2267 : IF (IANIM.EQ.0) LEGEND(9)=' ' 2268 : ELSE 2269 : LEGEND(5)=' ' 2270 : LEGEND(9)=' ' 2271 : ENDIF 2272 : IF (KDEFOR.NE.0) LEGEND(5)='Amplification' 2273 : IF (NCOMP.NE.0) LEGEND(6)='Composantes' 2273 : CALL MENU(LEGEND,NCASE,LLONG) 2274 : C 2275 : IRESU=0 2276 : C RECUPERATION DE LA CLE FRAPPEE 2276 : CALL TRAFF(ICLE) 2277 : C TRAITEMENT 2278 : IF (ICLE.NE.0) THEN 2279 : IF (ICLE.EQ.1) THEN 2279 : CALL PRZOOM(IRESU,ISORT,IQUALI,INUMNO,INUMEL, 2280 : $ XMI,XMA,YMI,YMA) 2281 : 2282 : 2283 : ENDIF 2284 : IF (ICLE.EQ.2) THEN 2284 : CALL rotvu(ioeini,ioeil,cgrav,xmi,xma,ymi,yma,zmi,zma,axez) 2285 : goto 7001 2286 : ENDIF 2287 : IF (ICLE.EQ.4) THEN 2288 : IF (KDEFOR.EQ.0) THEN 2289 : C AFFICHAGE DE VALEUR D'ISO 2290 : PAS=(X2-X1)/(XMA-XMI) 2290 : CALL ISOINT(VCPCHA,MELEME,ICPR,XPROJ,IVU,PAS, 2291 : $ XMI,YMI,X1,Y1,mcham) 2292 : IRESU=2 2293 : GOTO 6101 2294 : ELSE 2295 : * MODIFICATION DE L'AMPLIFICATION 2295 : CALL AMPINT(NDEF,VCHC,ampimp) 2296 : amplit=ampimp 2297 : siampl=ampimp 2298 : GOTO 7001 2299 : ENDIF 2300 : ENDIF 2301 : IF (ICLE.EQ.5.AND.NCOMP.NE.0) THEN 2301 : CALL COMPINT(NCOMP,LCOMP,COMPCH) 2302 : GOTO 7001 2303 : ENDIF 2303 : IF (ICLE.EQ.5) CALL CHANG(IRESU,ISORT,IQUALI,3) 2303 : IF (ICLE.EQ.6) CALL CHANG(IRESU,ISORT,INUMNO,4) 2303 : IF (ICLE.EQ.7) CALL CHANG(IRESU,ISORT,INUMEL,5) 2304 : IF (ICLE.EQ.11) THEN 2304 : CALL FLGI 2305 : ISORT=0 2306 : ENDIF 2307 : IF (ICLE.EQ.12) THEN 2307 : CALL IMPR 2308 : ISORT=0 2309 : ENDIF 2310 : * BERTIN: Traitement de la coupe 2311 : IF (ICLE.EQ.3) THEN 2312 : * Ecriture de maniere permanente du barycentre e ICOUP1. 2313 : IF (ZCOM.EQ.0) THEN 2313 : CALL ECROBJ('MAILLAGE',MELEME) 2313 : CALL BARYCE 2313 : CALL LIROBJ('POINT',IBARY,1,IRETOU) 2314 : IREF=(IBARY-1)*(IDIM+1) 2315 : BARY(1)=REAL(XCOOR(IREF+1)) 2316 : BARY(2)=REAL(XCOOR(IREF+2)) 2317 : BARY(3)=REAL(XCOOR(IREF+3)) 2318 : XB= BARY(1) 2319 : YB= BARY(2) 2320 : ZB= BARY(3) 2321 : ZCOM=1 2322 : nbpts=xcoor(/1)/(idim+1) 2323 : nbpts=nbpts+3 2324 : segadj mcoord 2325 : icoup1=nbpts-2 2326 : icoup2=nbpts-1 2327 : icoup3=nbpts 2328 : ENDIF 2329 : 2330 : XE=REAL( XCOOR((IOEIL-1)*(idim+1)+1) ) 2331 : YE=REAL( XCOOR((IOEIL-1)*(idim+1)+2) ) 2332 : ZE=REAL( XCOOR((IOEIL-1)*(idim+1)+3) ) 2333 : LEGEND(1)=' Retour ' 2334 : LEGEND(2)=' Annulation ' 2335 : LEGEND(3)=' Position ' 2336 : 2336 : CALL MENU(LEGEND,3,30) 2336 : call trmess('Pour une coupe choisir Position puis la definir') 2336 : CALL TRAFF(ICLE2) 2337 : 2338 : IF (ICLE2.EQ.0) GOTO 6105 2339 : 2340 : IF (ICLE2.EQ.1) THEN 2341 : ICOUP=0 2342 : mcou2=0 2343 : icou2=0 2344 : mcoup=0 2345 : coupol=-1. 2346 : GOTO 7001 2347 : ENDIF 2347 : call coupno(xmi,xma,ymi,yma,zmi,zma,coupra,coupol) 2348 : if(melemi.ne.0)then 2349 : mcoup=0 2350 : mcou2=0 2351 : meleme=melemi 2352 : endif 2353 : if(melei2.ne.0) melem2=melei2 2354 : icoup=1 2355 : * recherche du min et du max le long de oeil bary 2356 : xb=bary(1) 2357 : yb=bary(2) 2358 : zb=bary(3) 2359 : xm=xb-XE 2360 : ym= yb-YE 2361 : zm= zb-ZE 2362 : oeba=sqrt(xm*xm + ym*ym + zm*zm) 2363 : xm = xm / oeba 2364 : ym=ym/oeba 2365 : zm=zm/oeba 2366 : ipt7=meleme 2367 : ipt3=ipt7 2368 : segact ipt7 2369 : coupma= -1000.*oeba 2370 : coupmi= +1000.*oeba 2371 : do ipa=1,max(1,ipt7.lisous(/1)) 2372 : if( ipt7.lisous(/1).ne.0) then 2373 : ipt3=ipt7.lisous(ipa) 2374 : segact ipt3 2375 : endif 2376 : do ipb=1,ipt3.num(/2) 2377 : do ipc=1,ipt3.num(/1) 2378 : iu=ipt3.num(ipc,ipb)*(idim+1) 2379 : xu= real(xcoor(iu-3)) 2380 : yu= real(xcoor(iu-2)) 2381 : zu= real(xcoor(iu-1)) 2382 : dd= xm*(xb-xu) + ym*(yb-yu) +zm*(zb-zu) 2383 : if(coupma.lt.dd ) coupma=dd 2384 : if(coupmi.gt.dd ) coupmi=dd 2385 : enddo 2386 : enddo 2387 : if(ipt7.lisous(/1).ne.0) segdes ipt3 2388 : enddo 2389 : xbn = xb - xm*coupma + xm*coupra*(coupma-coupmi) 2390 : ybn = yb - ym*coupma + ym*coupra*(coupma-coupmi) 2391 : zbn = zb - zm*coupma + zm*coupra*(coupma-coupmi) 2392 : segact,mcoord*MOD 2393 : XCOOR((ICOUP1-1)*(idim+1)+1)=XBn 2394 : XCOOR((ICOUP1-1)*(idim+1)+2)=YBn 2395 : XCOOR((ICOUP1-1)*(idim+1)+3)=ZBn 2396 : 2397 : 2398 : if( (abs (XM) + abs(YM)) .ne. 0.) then 2399 : xcoor((icoup2-1)*(idim+1)+1 )= xbn - ym 2400 : xcoor((icoup2-1)*(idim+1)+2 )= ybn + xm 2401 : xcoor((icoup2-1)*(idim+1)+3 )= zbn 2402 : xcoor((icoup3-1)*(idim+1)+1 )= xbn - xm*zm 2403 : xcoor((icoup3-1)*(idim+1)+2 )= ybn - ym*zm 2404 : xcoor((icoup3-1)*(idim+1)+3 )= zbn + xm*xm + ym*ym 2405 : else 2406 : xcoor((icoup2-1)*(idim+1)+1 )= xbn + 1. 2407 : xcoor((icoup2-1)*(idim+1)+2 )= ybn 2408 : xcoor((icoup2-1)*(idim+1)+3 )= zbn 2409 : xcoor((icoup3-1)*(idim+1)+1 )= xbn 2410 : xcoor((icoup3-1)*(idim+1)+2 )= ybn + 1. 2411 : xcoor((icoup3-1)*(idim+1)+3 )= zbn 2412 : endif 2413 : write(IOIMP,*) ' points definissant la coupe' 2414 : icoy1=(ICOUP1-1)*(idim+1) 2415 : icoy2=(ICOUP2-1)*(idim+1) 2416 : icoy3=(ICOUP3-1)*(idim+1) 2417 : write(IOIMP,fmt='(3(e12.5,2X))')xcoor(icoy1+1),xcoor(icoy1+2) 2418 : $ ,xcoor(icoy1+3) 2419 : write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy2+1),xcoor(icoy2+2) 2420 : $ ,xcoor(icoy2+3) 2421 : write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy3+1),xcoor(icoy3+2) 2422 : $ ,xcoor(icoy3+3) 2423 : GOTO 7001 2424 : ENDIF 2425 : 2426 : IF (ICLE.EQ.9) THEN 2427 : LEGEND(1)= ' Retour ' 2428 : LEGEND(2)=' Isovaleurs' 2429 : IF (ZCHAM) THEN 2430 : LEGEND(3)=' (X) Champ' 2431 : ELSE 2432 : LEGEND(3)=' ( ) Champ' 2433 : ENDIF 2434 : IF (ZDATE) THEN 2435 : LEGEND(4)=' (X) Date ' 2436 : ELSE 2437 : LEGEND(4)=' ( ) Date ' 2438 : ENDIF 2439 : LEGEND(5)=' Fonts >> ' 2440 : IF (ICOSC.EQ.1) THEN 2441 : LEGEND(6)='Ecran>> Blanc' 2442 : ELSE IF (ICOSC.EQ.2) THEN 2443 : LEGEND(6)='Ecran>> Noir' 2444 : ENDIF 2445 : LEGEND(7)=' Pos Legende ' 2445 : CALL MENU(LEGEND,7,13) 2445 : CALL TRAFF(ICLE2) 2446 : * si on a change la fonte on sort 2447 : if (icle2.eq.7) icle2=0 2448 : 2449 : IF (ICLE2.EQ.0) GOTO 6105 2450 : 2451 : IF (ICLE2.EQ.1) THEN 2451 : CALL TRGET ('Entrer le nombre d''''isovaleurs : ', TMPCAR) 2452 : READ(TMPCAR,'(I2)') BA 2453 : ISOVU=BA 2454 : 2455 : GOTO 7001 2456 : ENDIF 2457 : 2458 : IF (ICLE2.EQ.2.and.(mchpoi.ne.0)) THEN 2459 : IF (ZCHAM) then 2460 : ZCHAM=.FALSE. 2461 : ELSE 2462 : ZCHAM=.TRUE. 2463 : ENDIF 2464 : GOTO 7001 2465 : ENDIF 2466 : 2467 : IF (ICLE2.EQ.3) THEN 2468 : IF (ZDATE) THEN 2469 : ZDATE=.FALSE. 2470 : ELSE 2471 : ZDATE=.TRUE. 2472 : ENDIF 2473 : GOTO 7001 2474 : ENDIF 2475 : IF (ICLE2.EQ.4) THEN 2476 : LEGEND(1)=' Retour ' 2477 : LEGEND(2)=' 8_BY_13 ' 2478 : LEGEND(3)=' 9_BY_15 ' 2479 : LEGEND(4)=' TIMES_10 ' 2480 : LEGEND(5)=' TIMES_24 ' 2481 : LEGEND(6)=' HELV_10 ' 2482 : LEGEND(7)=' HELV_12 ' 2483 : LEGEND(8)=' HELV_18 ' 2483 : CALL MENU(LEGEND,8,13) 2483 : CALL TRAFF(ICLE3) 2484 : IF (ICLE3.EQ.0) GOTO 7001 2485 : IOPOLI=ICLE3 2486 : GOTO 7001 2487 : ENDIF 2488 : IF (ICLE2.EQ.5) THEN 2489 : IF (ICOSC.EQ.1) THEN 2490 : ICOSC=2 2491 : ELSE IF (ICOSC.EQ.2) THEN 2492 : ICOSC=1 2493 : ENDIF 2494 : GOTO 7001 2495 : ENDIF 2496 : IF (ICLE2.EQ.6) THEN 2497 : ZLEGI=.TRUE. 2497 : CALL TRGET ('Translation en X de :', TMPCAR) 2498 : READ(TMPCAR,'(F4.2)') XHAUT 2498 : CALL TRGET ('Translation en Y de :', TMPCAR) 2499 : READ(TMPCAR,'(F4.2)') YHAUT 2500 : GOTO 7001 2501 : ENDIF 2502 : 2503 : ENDIF 2504 : 2505 : * BERTIN: Fin traitement 2506 : 2507 : IF (ISORT.EQ.0) GOTO 6105 2508 : C 2509 : ELSE 2509 : CALL MAJSEG(2,IRESU,IQUALI,INUMNO,INUMEL) 2510 : ENDIF 2511 : IF (IRESU.EQ.8) THEN 2512 : XMI=XMIN 2513 : XMA=XMAX 2514 : YMI=YMIN 2515 : YMA=YMAX 2516 : IRESU=1 2517 : ENDIF 2518 : IF (IRESU.EQ.2) THEN 2519 : GOTO 4202 2520 : ELSE IF (IRESU.EQ.1) THEN 2521 : X1=XMI 2522 : X2=XMA 2523 : Y1=YMI 2524 : Y2=YMA 2525 : Z1=ZMI 2526 : Z2=ZMA 2527 : IF (IDEFOR.NE.0) GOTO 1234 2528 : C IF (IECLAT.NE.1.AND.IFADES.NE.1) THEN PV JUIN 86 2529 : IF (IECLAT.NE.1) THEN 2530 : SEGACT KON,XPROJ,ICPR,IVU 2531 : DO 6004 I=1,NBCONR 2532 : DO J=1,KON(/3) 2533 : IF (KON(1,I,J).LT.0) KON(1,I,J)=-KON(1,I,J) 2534 : ENDDO 2535 : 6004 CONTINUE 2536 : 2537 : SEGDES KON 2538 : *PM NBCOUL-1 au lieu de 7 2539 : DO I=1,NBCOUL-1 2540 : ICHC(I)=ICHCS(I) 2541 : ENDDO 2541 : CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET) 2542 : GOTO 4999 2543 : ENDIF 2544 : SEGACT XPROJ 2544 : CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET) 2545 : GOTO 4201 2546 : ELSE IF (IRESU.EQ.3) THEN 2547 : GOTO 4202 2548 : ELSE IF (IRESU.EQ.4) THEN 2549 : GOTO 500 2550 : ELSE IF (IRESU.EQ.5) THEN 2551 : GOTO 531 2552 : ELSE IF (IRESU.EQ.6) THEN 2552 : CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET) 2553 : C IF (IECLAT.NE.1.AND.IFADES.NE.1) THEN PV JUIN 86 2554 : IF (IECLAT.NE.1) THEN 2555 : SEGSUP KON 2556 : GOTO 6010 2557 : ELSE 2558 : SEGACT XPROJ 2559 : GOTO 4201 2560 : ENDIF 2561 : ENDIF 2562 : SEGSUP XPROJ,ICPR,IVU 2563 : IF (IECLAT.NE.1) SEGSUP KON 2564 : IF (IDEFOR.NE.0) THEN 2565 : SEGSUP KABEL,KABCOR,KABCPR 2566 : SEGDES MDEFOR 2567 : ENDIF 2568 : IF ((MCOUP.NE.0).AND.(IDEFOR.EQ.0)) THEN 2569 : C NETTOYAGE APRES COUPE 2570 : SEGSUP MCOUP 2571 : SEGACT MCOORD*MOD 2572 : * SEGADJ MCOORD 2573 : SEGACT MELEME 2574 : DO IO=1,LISOUS(/1) 2575 : IPT1=LISOUS(IO) 2576 : SEGSUP IPT1 2577 : ENDDO 2578 : SEGSUP MELEME 2579 : ENDIF 2580 : IF (MVECTE.NE.0) SEGDES MVECTE 2581 : IF (VCPCHA.NE.0) SEGSUP VCPCHA 2582 : 2583 : C FIN de l'appel a PRTRAC - Cas particulier IDIM=1 2584 : C Recopie du segment MCOORD en DIMENSION 1 (retour a l'etat initial) 2585 : 8900 IF (IDIMSAV.NE.0) THEN 2586 : IDIM=IDIMSAV 2587 : SEGSUP MCOORD 2588 : MCOORD=ICOORSAV 2589 : SEGACT MCOORD 2590 : ENDIF 2591 : RETURN 2592 : 2593 : 7001 continue 2594 : if (icpr.ne.0) segsup icpr 2595 : if (ivu.ne.0) segsup ivu 2596 : if (ntseg.ne.0) segsup ntseg 2597 : if (kon.ne.0) segsup kon 2598 : if (xproj.ne.0) segsup xproj 2599 : if (xpro2.ne.0) segsup xpro2 2600 : if (kxpro2.ne.0) segsup kxpro2 2601 : if (kabel.ne.0) segsup kabel 2602 : if (kabcor.ne.0) segsup kabcor 2603 : if (labco2.ne.0) segsup labco2 2604 : if (kabel2.ne.0) segsup kabel2 2605 : if (kabco3.ne.0) segsup kabco3 2606 : if (labco3.ne.0) segsup labco3 2607 : if (kabco2.ne.0) segsup kabco2 2608 : if (icor2.ne.0) segsup icor2 2609 : if (kabcpr.ne.0) segsup kabcpr 2610 : if (kabcp2.ne.0) segsup kabcp2 2611 : if (mvecte.ne.0) segact mvecte 2612 : if (mcoup.ne.0) segsup mcoup 2613 : if (vcpcha.ne.0) segsup vcpcha 2614 : idefor=idefs 2615 : ipv=1 2616 : * if (mdefos.ne.-1) mdefor=mdefos 2617 : if (melsau.ne.0) meleme=melsau 2618 : INWDS=INWDS2 2619 : goto 4210 2620 : END 2621 : 2622 : 2623 : 2624 : 2625 : 2626 : 2627 : 2628 : 2629 : 2630 : 2631 : 2632 : 2633 : 2634 : 2635 : 2636 : 2637 : 2638 :
© Cast3M 2003 - All rights reserved.
Disclaimer