1 : C TREVOL SOURCE BP208322 13/03/18 21:15:00 7722 2 : SUBROUTINE TREVOL (IPTR1,IPTR2,CHAINE,TITOPT,ZLEGE,NCT,NLG,INBEVO 3 : & ,IPOSI,XPOSI,YPOSI) 4 : *============================================================= 5 : * Modifications : 6 : * 7 : * 95/02/07 Loca 8 : * passer les legendes x et y de 12 à 20 caractères: 9 : * SEGMENT AXE disparait et est appelé en include: -INC TMAXE. 10 : * 11 : * 2004 Maugis 12 : * Légendes à partir du haut, avec un espacement dépendant de leur nombre 13 : * Possibilité de ne pas écrire de légende pour une courbe donnée 14 : * 15 : * 05 sept. 2007 Maugis 16 : * Affichage de marqueurs aussi lorsqu'ils sont sur un bord 17 : * Maintien du segment AXE actif en modification 18 : * Mise du point en premier type de marqueur 19 : * Ajout de formes de marqueurs, dont 2 autres triangles TRIL et TRIR 20 : * pointant horizontalement, on garde pour compatibilité TRIA et TRIB, 21 : * qui peuvent maintenant être invoqués avec TRID et TRIU 22 : * respectivement. 23 : * Correction de tracé (ou absence de tracé) illicite avec REGU 24 : * avec marqueurs aux extrémités 25 : * 26 : *============================================================= 27 : * 28 : * Entrée : 29 : * 30 : * IPTR1 : POINTEUR SUR UN AXE (ACTIF) 31 : * IPTR2 : POINTEUR SUR UN KEVOLL 32 : * CHAINE : MOT CONTENANT LES OPTIONS SPECIFIQUES 33 : * ZLEGE : INDIQUE QUE L'ON EST EN MODE LEGENDE DES COURBES 34 : * NCT : NUMERO A AFFICHER SUR LA COURBE 35 : * NLG : NOMBRE DE LÉGENDES À AFFICHER AU TOTAL 36 : * INBEVO : NOMBRE TOTAL D'EVOLUTIONS 37 : * IPOSI position predefinie de la legende 38 : * XPOSI, YPOSI = position XY de la legende fourni par l utilisateur 39 : * 40 : *============================================================= 41 : * 42 : * TOUTES LES VARIABLES COMMENCANT PAR T SONT EN SIMPLE PRECISION ! 43 : * 44 : * MMT : MOT EXTRAIT DE CHAINE 45 : * ZREGU : REPERE ESPACE REGULIEREMENT 46 : * ZTIRET : TIRET ENTRE POINTS 47 : * ZNOLI : ABSENCE DE LIGNE ENTRE POINT 48 : * ZLABEL : ECRITURE D'EN LABEL 49 : * ZPLEIN : Le marqueur doit être rempli 50 : * LTAIL : TABLE des tailles 51 : * XTAIL : facteur multiplicatif de taille du marqueur 52 : * IEPAI : facteur multiplicatif (entier) de l'épaisseur des traits du marqueur 53 : * IMARQ : NUMERO DE LA FORME DU MARQUEUR (=0 <=> PAS DE MARQUEUR) 54 : * NMARQ : NOMBRE DE FORMES POSSIBLES DE MARQUEURS 55 : * LMARQ : TABLE DES MARQUEURS 56 : * NREGU : NOMBRE DE MARQUEURS PAR COURBE EN DISPOSITION REGULIERE 57 : * NLGMIN : NOMBRE MINIMAL DE LEGENDES 58 : * NLGMAX : NOMBRE MAXIMAL DE LEGENDES 59 : * INB : NOMBRE DE POINTS A TRAITER 60 : * 61 : *============================================================= 62 : IMPLICIT INTEGER(I-N) 63 : IMPLICIT REAL*8 (A-H,O-S,U-Y) 64 : C*? IMPLICIT REAL*4 (T) 65 : IMPLICIT LOGICAL (Z) 66 : * 67 : -INC SMEVOLL 68 : -INC SMLREEL 69 : -INC TMAXE 70 : -INC CCREEL 71 : -INC CCOPTIO 72 : -INC CCTRACE 73 : * 74 : EXTERNAL LONG 75 : PARAMETER (NREGU=8,NLGMIN=19,NLGMAX=30,NMARQ=15,NCLEF=9,NTAIL=7) 76 : REAL HMIN,TYYM 77 : REAL*8 IEPAI 78 : CHARACTER*72 CHAINE,CHVIDE 79 : CHARACTER*20 TITOPT 80 : CHARACTER*72 MLABEL 81 : CHARACTER*12 MMT,FMMT 82 : CHARACTER*4 LMARQ(NMARQ),LCLEF(NCLEF),LTAIL(NTAIL) 83 : CHARACTER CC 84 : DIMENSION TX(2),TY(2) 85 : DIMENSION TRX(6),TRY(6),TRZ(6) 86 : 87 : * on garde TRIA et TRIB pour compatibilité 88 : DATA LMARQ /'POIN','CROI','PLUS','ETOI','CARR','LOSA', 89 : & 'TRIA','TRIB','TRIL','TRIR','TRID','TRIU', 90 : & 'MOIN','BARR','ROND'/ 91 : DATA LCLEF /'REGU','NOLI','TIRR','TIRC','TIRL','TIRM','MARQ', 92 : & 'REMP','POIN'/ 93 : DATA LTAIL /'SS ','S ','M ','L ','XL ','XXL ','TAIL'/ 94 : 95 : * Valeurs par défaut 96 : ZREGU = .FALSE. 97 : ZNOLI = .FALSE. 98 : ZTIRET = .FALSE. 99 : KTIR = 0 100 : ZLABEL = .FALSE. 101 : IMARQ = 0 102 : ZPLEIN = .FALSE. 103 : XTAIL = 1.D0 104 : IEPAI = 1.D0 105 : CHVIDE(1:72)=' ' 106 : ZREMP = .FALSE. 107 : DO I=1,5 108 : TRZ(I)=0. 109 : ENDDO 110 : IF (ICOSC.EQ.1) THEN 111 : ICOMBR=7 112 : ELSE 113 : ICOMBR=8 114 : ENDIF 115 : 116 : * 117 : * ==================================================================== 118 : * TRAITEMENT DES OPTIONS 119 : * ==================================================================== 120 : * 121 : IF (CHAINE(1:72).NE.CHVIDE(1:72)) THEN 122 : I=1 123 : 1 CONTINUE 123 : CALL EXTRAC (CHAINE,I,MMT) 124 : IF (MMT.NE.CHVIDE) THEN 124 : CALL PLACE(LCLEF,NCLEF,ICLEF,MMT(1:4)) 125 : 126 : * 'REGU' 127 : IF (ICLEF.EQ.1) ZREGU=.TRUE. 128 : 129 : * 'NOLI' 130 : IF (ICLEF.EQ.2) ZNOLI=.TRUE. 131 : 132 : * 'TIRR'/'TIRC'/'TIRL'/'TIRM' / 'POIN' 133 : IF (ICLEF.EQ.3) THEN 134 : ZTIRET=.TRUE. 135 : KTIR=1 136 : ENDIF 137 : IF (ICLEF.EQ.4) THEN 138 : ZTIRET=.TRUE. 139 : KTIR=2 140 : ENDIF 141 : IF (ICLEF.EQ.5) THEN 142 : ZTIRET=.TRUE. 143 : KTIR=3 144 : ENDIF 145 : IF (ICLEF.EQ.6) THEN 146 : ZTIRET=.TRUE. 147 : KTIR=4 148 : ENDIF 149 : IF (ICLEF.EQ.9) THEN 150 : ZTIRET=.TRUE. 151 : KTIR=5 152 : ENDIF 153 : 154 : * 'MARQ' 155 : IF (ICLEF.EQ.7) THEN 156 : * La présence de ce mot-clef réinitialise les options de 157 : * marqueur, pour le cas de spécifications successives 158 : ZPLEIN = .FALSE. 159 : XTAIL = 1.D0 160 : IEPAI = 1.D0 161 : IMARQ = 0 161 : 20 CALL EXTRAC(CHAINE,I,MMT) 162 : * remplir le marqueur ? 163 : IF (MMT(1:4).EQ.'PLEI') THEN 164 : ZPLEIN = .TRUE. 165 : GOTO 20 166 : ENDIF 167 : * taille du marqueur 167 : CALL PLACE(LTAIL,NTAIL,ITAIL,MMT(1:4)) 168 : * write(6,*) ' taille du marqueur ' , itail 169 : IF (ITAIL.NE.0) THEN 170 : IF (ITAIL.EQ.1) XTAIL = 0.25D0 171 : IF (ITAIL.EQ.2) XTAIL = 0.50D0 172 : IF (ITAIL.EQ.3) XTAIL = 1.00D0 173 : IF (ITAIL.EQ.4) XTAIL = 1.25D0 174 : IF (ITAIL.EQ.5) XTAIL = 1.75D0 175 : IF (ITAIL.EQ.6) XTAIL = 2.50D0 176 : IF (ITAIL.EQ.7) THEN 177 : ** spécification d'une taille arbitraire 178 : ** (la croix et la banière pour convertir en flottant!) 178 : * CALL EXTRAC(CHAINE,I,MMT) 179 : * LMMT = LONG(MMT) 180 : * WRITE(cc,FMT='(I1)') LMMT 181 : * FMMT = '(I'//cc//')' 182 : * READ(MMT,FMT=FMMT(1:4)) I1 183 : * XTAIL = I1 184 : ENDIF 185 : GOTO 20 186 : ENDIF 187 : * épaisseur de ligne (entre 0 et 9) 188 : IF (MMT(1:4).EQ.'EPAI') THEN 188 : CALL EXTRAC(CHAINE,I,MMT) 189 : READ(MMT,FMT='(I1)') IEPAI 190 : GOTO 20 191 : ENDIF 192 : * type de marqueur (en dernier) 192 : CALL PLACE(LMARQ,NMARQ,IMARQ,MMT(1:4)) 193 : * write(6,*) ' type du marqueur ' , imarq 194 : IF (IMARQ.EQ.0) THEN 195 : * On ne comprend pas le mot %m1:4 196 : moterr(1:4) = MMT(1:4) 196 : CALL ERREUR(7) 197 : ENDIF 198 : ENDIF 199 : 200 : * 'REMP' 201 : IF (ICLEF.EQ.8) ZREMP=.TRUE. 202 : 203 : * 'LABEL' 204 : IF (MMT(1:4).EQ.'LABE') THEN 205 : ZLABEL=.TRUE. 205 : CALL EXTRAC(CHAINE,I,MLABEL) 206 : ENDIF 207 : IF (I.LE.72) GOTO 1 208 : ENDIF 209 : ENDIF 210 : 211 : * 212 : AXE=IPTR1 213 : KEVOLL=IPTR2 214 : SEGACT KEVOLL 215 : MLREEL=IPROGX 216 : SEGACT MLREEL 217 : MLREE1=IPROGY 218 : SEGACT MLREE1 219 : INB = PROG(/1) 220 : c Cas TRES particulier : 221 : IF (INB.LE.0) ZREGU = .FALSE. 222 : HMIN = .2 223 : DXEVL = XSUP-XINF 224 : DYEVL = YSUP-YINF 225 : DL = DXEVL/100.D0 226 : ZTRAC =.TRUE. 227 : YZERO = MIN(MAX(0.D0,YINF),YSUP) 228 : c IF (NUMEVY.EQ.'HIST') ZREMP=.TRUE. 229 : * 230 : * ==================================================================== 231 : * TRACE DE BASE 232 : * ==================================================================== 233 : * 234 : nlocab=numevx 234 : CALL CHCOUL(Nlocab) 235 : * 236 : * On rajoute cette étiquette pour gérer le fait que dans certains 237 : * cas (histogrammes par exemple), il faut tracer la totalité des 238 : * remplissages avant de tracer les segments, sinon ils seront 239 : * recouverts 240 : ZNOLI1=ZNOLI 241 : ZREMP1=ZREMP 242 : IF (.NOT.ZNOLI.AND.ZREMP) ZNOLI1=.TRUE. 243 : 30 CONTINUE 244 : 245 : cbp : on va faire le travail pour espacement REGU des marqueurs ici 246 : IF (ZREGU) THEN 247 : xlonx=(xsup-xinf)**2 248 : xlony=(ysup-yinf)**2 249 : xlong=0.d0 250 : jg=inb-1 251 : segini,MLREE2 252 : ENDIF 253 : 254 : 255 : *==== BOUCLE SUR LES SEGMENTS ========================================= 256 : DO 4 i = 1,inb-1 257 : * 258 : *-------CALCUL COORDONNEES (CORRIGEES SI LOG)------- 259 : c -recup 260 : X1=PROG(I) 261 : X2=PROG(I+1) 262 : Y1=MLREE1.PROG(I) 263 : Y2=MLREE1.PROG(I+1) 264 : c -coordonnee X 265 : IF (ZLOGX) THEN 266 : c on verifie qu'on n'a pas des infinis (si YBOR précisé par ex.) 267 : if(X1.le.0.D0.and.X2.le.0.d0) goto 4 268 : if(X1.gt.0.D0) then 269 : TX(1) = LOG10(X1) 270 : else 271 : c cas segment horizontal avec 1er point infini 272 : TX(1) = XINF 273 : TY(1) = TY(2) 274 : endif 275 : if(X2.gt.0.D0) then 276 : TX(2) = LOG10(X2) 277 : else 278 : c cas segment horizontal avec 2eme point infini 279 : TX(2) = XINF 280 : TY(2) = TY(1) 281 : endif 282 : ELSE 283 : TX(1) = X1 284 : TX(2) = X2 285 : ENDIF 286 : c -coordonnee Y 287 : IF (ZLOGY) THEN 288 : c on verifie qu'on n'a pas des infinis (si YBOR précisé par ex.) 289 : c cas points 1 et 2 infinis => on saute car segment non défini 290 : if(Y1.le.0.D0.and.Y2.le.0.d0) goto 4 291 : if(Y1.gt.0.D0) then 292 : TY(1) = LOG10(Y1) 293 : else 294 : c cas segment vertical avec 1er point infini 295 : TX(1) = TX(2) 296 : TY(1) = YINF 297 : endif 298 : if(Y2.gt.0.D0) then 299 : TY(2) = LOG10(Y2) 300 : else 301 : c cas segment vertical avec 2eme point infini 302 : TX(2) = TX(1) 303 : TY(2) = YINF 304 : endif 305 : ELSE 306 : TY(1) = Y1 307 : TY(2) = Y2 308 : ENDIF 309 : c write(6,*) 'i=',i,X1,Y1,' - ',X2,Y2 310 : c write(6,*) '->',i,TX(1),TY(1),' - ',TX(2),TY(2) 311 : 312 : *-------CALCUL DES EXTREMA DE LA COURBE------- 313 : IF (I.EQ.1) THEN 314 : XMINT = TX(1) 315 : XMAXT = TX(1) 316 : YMINT = TY(1) 317 : YMAXT = TY(1) 318 : ENDIF 319 : xtx2=TX(2) 320 : yty2=ty(2) 321 : XMINT = MIN (XMINT,xtx2) 322 : XMAXT = MAX (XMAXT,xtx2) 323 : YMINT = MIN (YMINT,yTY2) 324 : YMAXT = MAX (YMAXT,yTY2) 325 : * 326 : *-------POUR CHAQUE SEGMENT : ON VERIFIE S'IL APPARAIT DANS LA FENETRE-- 327 : * 328 : * -SEGMENT HORS FENETRE ? 329 : * attention : il faut éventuellement le "remplir" quand même -> goto 41 330 : * XMAX trop a gauche 331 : XMAX=MAX(TX(1),TX(2)) 332 : IF (XMAX.LT.XINF) GOTO 4 333 : * XMIN trop a droite 334 : XMIN=MIN(TX(1),TX(2)) 335 : IF (XMIN.GT.XSUP) GOTO 4 336 : * YMAX trop bas 337 : YMAX=MAX(TY(1),TY(2)) 338 : IF (YMAX.LT.YINF) GOTO 41 339 : * YMIN trop haut 340 : YMIN=MIN(TY(1),TY(2)) 341 : IF (YMIN.GT.YSUP) GOTO 41 342 : * 343 : * -EXTREMITE 1 DANS LA FENETRE ? 344 : IF((TX(1).GE.XINF).AND.(TX(1).LE.XSUP).AND. 345 : $ (TY(1).GE.YINF).AND.(TY(1).LE.YSUP)) GOTO 5 346 : * 347 : * -EXTREMITE 2 DANS LA FENETRE ? 348 : IF((TX(2).GE.XINF).AND.(TX(2).LE.XSUP).AND. 349 : $ (TY(2).GE.YINF).AND.(TY(2).LE.YSUP)) GOTO 5 350 : * 351 : * si on est là (et pas en 5), c'est qu' 352 : * -AUCUNE EXTREMITE DANS LA FENETRE MAIS SEGMENT SECANT 353 : 354 : * Cas segment vertical 355 : IF (TX(1).EQ.TX(2)) THEN 356 : IF ((TX(1).GT.XINF).AND.(TX(1).LT.XSUP)) THEN 357 : GOTO 5 358 : ELSE 359 : GOTO 4 360 : ENDIF 361 : ENDIF 362 : 363 : * Cas segment non vertical 364 : A = (TY(2)-TY(1)) / (TX(2)-TX(1)) 365 : IF (DABS(A).LT.1D-10) A=0.D0 366 : 367 : Y = A * (XINF-TX(1))+TY(1) 368 : * Cas segment horizontal 369 : IF (A.EQ.0.D0) THEN 370 : IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) THEN 371 : GOTO 5 372 : ELSE 373 : GOTO 41 374 : ENDIF 375 : ENDIF 376 : IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) GOTO 5 377 : Y=A*(XSUP-TX(1))+TY(1) 378 : IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) GOTO 5 379 : X=TX(1)+(YINF-TY(1))/A 380 : IF ((X.LT.XSUP) .AND. (X.GT.XINF)) GOTO 5 381 : X=TX(1)+(YSUP-TY(1))/A 382 : IF ((X.LT.XSUP) .AND. (X.GT.XINF)) GOTO 5 383 : 384 : GOTO 41 385 : 386 : *-------AU MOINS UN POINT DANS LA FENETRE------- 387 : 5 CONTINUE 388 : 389 : * Cas segment vertical 390 : IF (TX(1).EQ.TX(2)) THEN 391 : IF (TY(1).LT.YINF) TY(1)=YINF 392 : IF (TY(2).GT.YSUP) TY(2)=YSUP 393 : * Pas besoin de tracer le remplissage éventuel ! 394 : GOTO 51 395 : ENDIF 396 : 397 : * (DBLE pour empecher une erreur de compilation sur certaines machines...) 398 : IF (ZREMP1) THEN 399 : TRX(1)=MIN(MAX(DBLE(TX(1)),XINF),XSUP) 400 : TRY(1)=MIN(MAX(DBLE(TY(1)),YINF),YSUP) 401 : TRX(2)=MIN(MAX(DBLE(TX(2)),XINF),XSUP) 402 : TRY(2)=MIN(MAX(DBLE(TY(2)),YINF),YSUP) 403 : ENDIF 404 : * 405 : * LINEARISE LE PREMIER POINT EN X 405 : IF (TX(1).LT.XINF) CALL LINEAX (TX,TY,XINF,1) 405 : IF (TX(1).GT.XSUP) CALL LINEAX (TX,TY,XSUP,1) 406 : * 407 : * LINEARISE LE PREMIER POINT EN Y 407 : IF (TY(1).LT.YINF) CALL LINEAX (TY,TX,YINF,1) 407 : IF (TY(1).GT.YSUP) CALL LINEAX (TY,TX,YSUP,1) 408 : * 409 : * LINEARISE LE SECOND POINT EN X 409 : IF (TX(2).LT.XINF) CALL LINEAX (TX,TY,XINF,2) 409 : IF (TX(2).GT.XSUP) CALL LINEAX (TX,TY,XSUP,2) 410 : * 411 : * LINEARISE LE SECOND POINT EN Y 411 : IF (TY(2).LT.YINF) CALL LINEAX (TY,TX,YINF,2) 411 : IF (TY(2).GT.YSUP) CALL LINEAX (TY,TX,YSUP,2) 412 : c write(6,*) 'lineax:',TX(1),TX(2),TY(1),TY(2) 413 : 414 : IF (ZREMP1) THEN 415 : NP=4 416 : DO II=1,2 417 : JJ=II+NP-4 418 : IF (TX(II).NE.TRX(JJ).OR.TY(II).NE.TRY(JJ)) THEN 419 : NP=NP+1 420 : TRX(NP-2)=TRX(NP-3) 421 : TRY(NP-2)=TRY(NP-3) 422 : TRX(NP-3)=TX(II) 423 : TRY(NP-3)=TY(II) 424 : ENDIF 425 : ENDDO 426 : TRX(NP-1)=TRX(NP-2) 427 : TRY(NP-1)=YZERO 428 : TRX(NP) =TRX(1) 429 : TRY(NP) =YZERO 430 : * tracé du remplissage 430 : CALL TRFACE(NP,TRX,TRY,TRZ,1.,NLOCAB,IEFF) 431 : ENDIF 432 : 433 : 51 CONTINUE 434 : IF (.NOT.ZNOLI1) THEN 435 : * tracé du segment 435 : IF (ZREMP) CALL CHCOUL(ICOMBR) 435 : CALL TRSEG (IPTR1,TX,TY,ZTIRET,KTIR,DL,ZTRAC) 435 : IF (ZREMP) CALL CHCOUL(NLOCAB) 436 : 437 : * Ni ligne, ni remplissage, ni marqueur => marqueur par défaut 438 : cbp : bizarre car non compatible avec REGU... => pour eviter de passer 439 : cbp ici, l utilisateur doit preciser ce qu'il veut (LIGN ou MARQ ...) 440 : ELSEIF (IMARQ.EQ.0.AND..NOT.ZREMP1) THEN 441 : * tracé du point + le 2e si dernier segment 441 : CALL DMARQ(IPTR1,TX(1),TY(1),1,1D0,.FALSE.,0) 442 : IF (I.EQ.(INB-1)) 442 : & CALL DMARQ(IPTR1,TX(2),TY(2),1,1D0,.FALSE.,0) 443 : ENDIF 444 : 445 : cbp : on calcule la longueur de la courbe xlong ici 446 : IF (ZREGU) THEN 447 : X2=(TX(2)-TX(1))**2 448 : Y2=(TY(2)-TY(1))**2 449 : xll=sqrt(X2/xlonx+Y2/xlony) 450 : xlong=xlong+sqrt(X2/xlonx+Y2/xlony) 451 : MLREE2.PROG(I)=xlong 452 : ENDIF 453 : 454 : GOTO 4 455 : 456 : * LABEL 41 : 457 : *-----LE SEGMENT N'EST PAS DANS LA FENETRE, MAIS SON REMPLISSAGE PEUT Y ETRE 458 : 41 CONTINUE 459 : 460 : IF (ZREMP1) THEN 461 : 462 : TRX(1)=MIN(MAX(DBLE(TX(1)),XINF),XSUP) 463 : TRY(1)=MIN(MAX(DBLE(TY(1)),YINF),YSUP) 464 : TRX(2)=MIN(MAX(DBLE(TX(2)),XINF),XSUP) 465 : TRY(2)=MIN(MAX(DBLE(TY(2)),YINF),YSUP) 466 : 467 : * Finalement, le segment projete son remplissage hors de la fenetre... 468 : IF (TX(1).EQ.TX(2).AND.TY(1).EQ.TY(2)) GOTO 4 469 : 470 : * ... ou alors le remplissage est d'epaisseur nulle 471 : IF (TRY(1).EQ.YZERO) GOTO 4 472 : 473 : TRX(3)=TRX(2) 474 : TRY(3)=YZERO 475 : TRX(4)=TRX(1) 476 : TRY(4)=YZERO 477 : 478 : * tracé du remplissage 478 : CALL TRFACE(4,TRX,TRY,TRZ,1.,NLOCAB,IEFF) 479 : ENDIF 480 : 481 : 482 : 4 CONTINUE 483 : *==== FIN DE LA BOUCLE SUR LES SEGMENTS DE LA COURBE ================== 484 : 485 : IF (.NOT.ZNOLI.AND.ZREMP) THEN 486 : ZNOLI1=.NOT.ZNOLI1 487 : ZREMP1=.NOT.ZREMP1 488 : IF (.NOT.ZREMP1) GOTO 30 489 : ENDIF 490 : 491 : * 492 : * ==================================================================== 493 : * TRACE DU NOM DE LA COURBE 494 : * ==================================================================== 494 : CALL LENCHA(NOMEVY,LC) 495 : IF (NUMEVY.EQ.'HIST'.AND.LC.GT.0) THEN 496 : TDELTX=ABS(XSUP-XINF)/45 497 : TDELTY=ABS(YSUP-YINF)/45 498 : BORX1=MAX(XINF,XMINT) 499 : BORX2=MIN(XSUP,XMAXT) 500 : BORY2=MIN(YSUP,YMAXT) 501 : TXX=0.5*(BORX1+BORX2) 502 : TYY=BORY2+TDELTY 503 : TXX2=TXX-0.125*TDELTX*LC 504 : TYY2=TYY+TDELTY 504 : CALL DMARQ (IPTR1,TXX,TYY,7,1D0,.FALSE.,NLOCAB) 505 : HMIN=0.2 505 : CALL TRLABL(TXX2,TYY2,0.,NOMEVY,LC,HMIN) 506 : ENDIF 507 : * 508 : * ==================================================================== 509 : * TRACE DE MARQUEURS OU DE LABEL 510 : * ==================================================================== 511 : * 512 : * write(6,*)'iepai xtail zplein,nlocab',iepai,xtail,zplein,nlocab 513 : IF ((IMARQ.NE.0).OR.ZLABEL) THEN 514 : * 515 : * EN CHAQUE POINT 516 : * 517 : IF (.NOT. ZREGU) THEN 518 : DO 6 I=1,INB 519 : IF (ZLOGX) THEN 520 : TXX=LOG10(PROG(I)) 521 : ELSE 522 : TXX=PROG(I) 523 : ENDIF 524 : IF (ZLOGY) THEN 525 : TYY=LOG10(MLREE1.PROG(I)) 526 : ELSE 527 : TYY=MLREE1.PROG(I) 528 : ENDIF 529 : * tracé si à peu près dans fenêtre 530 : IF ((TXX-XINF.GE.-XZPREC*DXEVL) .AND. 531 : & (TXX-XSUP.LE. XZPREC*DXEVL) .AND. 532 : & (TYY-YINF.GE.-XZPREC*DYEVL) .AND. 533 : & (TYY-YSUP.LE. XZPREC*DYEVL)) THEN 534 : IF (ZLABEL) 534 : & CALL TRLABL(TXX,TYY,0.,MLABEL,72,HMIN) 535 : IF (IMARQ.NE.0) THEN 535 : CALL DMARQ(IPTR1,TXX,TYY,IMARQ,XTAIL, 536 : & ZPLEIN,NLOCAB) 537 : ENDIF 538 : ENDIF 539 : 6 CONTINUE 540 : ENDIF 541 : * 542 : * RÉGULIÈREMENT 543 : * 544 : * write(6,*) ' nregu' , nregu 545 : IF (ZREGU) THEN 546 : * 547 : * calcul de la longueur de la courbe xlong 548 : * 549 : cbp : fait + haut 550 : c xlonx=(xsup-xinf)**2 551 : c xlony=(ysup-yinf)**2 552 : c xlong=0.d0 553 : c IF(ZLOGX) THEN 554 : c XX=LOG10(PROG(1)) 555 : c ELSE 556 : c XX=PROG(1) 557 : c ENDIF 558 : c IF(ZLOGY) THEN 559 : c YY=LOG10(MLREE1.PROG(1)) 560 : c ELSE 561 : c YY=MLREE1.PROG(1) 562 : c ENDIF 563 : c c on restreint les points de la courbe a l'intervalle borné 564 : c XX=MIN(xsup,MAX(xinf,XX)) 565 : c YY=MIN(ysup,MAX(yinf,YY)) 566 : c do iy=2,prog(/1) 567 : c IF(ZLOGX) THEN 568 : c X1=LOG10(PROG(iy)) 569 : c ELSE 570 : c X1=PROG(iy) 571 : c ENDIF 572 : c IF(ZLOGY) THEN 573 : c Y1=LOG10(MLREE1.PROG(iy)) 574 : c ELSE 575 : c Y1=MLREE1.PROG(iy) 576 : c ENDIF 577 : c c on restreint les points de la courbe a l'intervalle borné 578 : c X1=MIN(xsup,MAX(xinf,X1)) 579 : c Y1=MIN(ysup,MAX(yinf,Y1)) 580 : c X2=(X1-XX)**2 581 : c XX=X1 582 : c Y2=(Y1-YY)**2 583 : c YY=Y1 584 : c xll=sqrt(X2/xlonx+Y2/xlony) 585 : c c write(6,*) 'segment',iy,' ->',xll 586 : c xlong=xlong+sqrt(X2/xlonx+Y2/xlony) 587 : c enddo 588 : npart=nregu 589 : xlongp= xlong / npart 590 : c write(6,*) 'xinf,xsup,yinf,ysup=',xinf,xsup,yinf,ysup 591 : c write(6,*) 'xlong,nregu,xlongp=',xlong,nregu,xlongp 592 : * 593 : * tracé des marqueurs régulièrement espacés 594 : * 595 : xmar=xlongp/2.d0 596 : xdes=xlongp/10. 597 : xloo= 0.D0 598 : c IF (ZLOGX) THEN 599 : c XX = LOG10(PROG(1)) 600 : c ELSE 601 : c XX = PROG(1) 602 : c ENDIF 603 : c IF (ZLOGY) THEN 604 : c YY = LOG10(MLREE1.PROG(1)) 605 : c ELSE 606 : c YY = MLREE1.PROG(1) 607 : c ENDIF 608 : c c on restreint les points de la courbe a l'intervalle borné 609 : c XX=MIN(xsup,MAX(xinf,XX)) 610 : c YY=MIN(ysup,MAX(yinf,YY)) 611 : do iy=2,prog(/1) 612 : IF(ZLOGX) THEN 613 : X1=LOG10(PROG(iy)) 614 : ELSE 615 : X1=PROG(iy) 616 : ENDIF 617 : IF(ZLOGY) THEN 618 : Y1=LOG10(MLREE1.PROG(iy)) 619 : ELSE 620 : Y1=MLREE1.PROG(iy) 621 : ENDIF 622 : TXX=X1 623 : TYY=Y1 624 : c c on restreint les points de la courbe a l'intervalle borné 625 : c c pour le calcul de la longueur xloo 626 : c X1=MIN(xsup,MAX(xinf,X1)) 627 : c Y1=MIN(ysup,MAX(yinf,Y1)) 628 : c X2=(X1-XX)**2 629 : c XX=X1 630 : c Y2=(Y1-YY)**2 631 : c YY=Y1 632 : c xloo=xloo+sqrt ( x2/xlonx+y2/xlony) 633 : xloo=MLREE2.PROG(iy-1) 634 : * tracé si on a cumulé une longueur xmar 635 : if(xloo.gt.xmar)then 636 : * et si à peu près dans fenêtre 637 : IF ((TXX-XINF.GE.-XZPREC*DXEVL) .AND. 638 : & (TXX-XSUP.LE. XZPREC*DXEVL) .AND. 639 : & (TYY-YINF.GE.-XZPREC*DYEVL) .AND. 640 : & (TYY-YSUP.LE. XZPREC*DYEVL)) THEN 641 : IF (ZLABEL) 641 : & CALL TRLABL(TXX,TYY,0.,MLABEL,72,HMIN) 642 : IF (IMARQ.NE.0) THEN 642 : CALL DMARQ(IPTR1,TXX,TYY,IMARQ,XTAIL, 643 : & ZPLEIN,NLOCAB) 644 : ENDIF 645 : ENDIF 646 : 999 continue 647 : xmar=xmar+xlongp 648 : c si on a deja depassé xmar+xdes il faut aller chercher + loin 649 : if(xloo.gt.xmar+xdes) then 650 : c write(ioimp,*) ' on saute un point' 651 : go to 999 652 : endif 653 : endif 654 : enddo 655 : 656 : segsup,MLREE2 657 : ENDIF 658 : * fin du cas RÉGULIÈREMENT 659 : * 660 : * 9 CONTINUE 661 : 662 : ENDIF 663 : * 664 : * ==================================================================== 665 : * TRACÉ DE LA LÉGENDE AUPRÈS D'UN ÉCHANTILLON DE LIGNE 666 : * ==================================================================== 667 : * 668 : IF (ZLEGE.AND.(TITOPT(1:20).NE.'PAS DE LEGENDE')) THEN 669 : 670 : * on positionne la legende par rapport XPOS1 YPOS1 671 : * definis en fonction de IPOSI 672 : * position X pour les cas NO et SO 673 : if(IPOSI.eq.1.or.IPOSI.eq.3) then 674 : XPOS1 = XINF + (.06*BG) 675 : BREF = 4.*BG 676 : endif 677 : * position X pour les cas NE et SE 678 : if(IPOSI.eq.2.or.IPOSI.eq.4) then 679 : c rem BP: On positionne pour etre OK avec la police de la sortie PS 680 : c et tant pis pour l ecran (par defaut opti poli '8_BY_13';) 681 : if(ZCARRE) then 682 : BREF = 0.72*BD 683 : else 684 : BREF = 4.*BD 685 : endif 686 : if(IOPOTR.le.3) then 687 : XPOS1 = XSUP - (0.95*BREF) 688 : elseif(IOPOTR.le.6) then 689 : XPOS1 = XSUP - (1.05*BREF) 690 : elseif(IOPOTR.le.9) then 691 : XPOS1 = XSUP - (1.15*BREF) 692 : else 693 : XPOS1 = XSUP - (1.25*BREF) 694 : endif 695 : endif 696 : * position X pour le cas EXT 697 : if(IPOSI.eq.5) then 698 : XPOS1 = XSUP 699 : BREF = BD 700 : endif 701 : * position XPOSI fourni par l utilisateur 702 : if(IPOSI.eq.6) then 703 : IF(ZLOGX) THEN 704 : XPOS1 = LOG10(XPOSI) 705 : ELSE 706 : XPOS1 = XPOSI 707 : ENDIF 708 : BREF = 4.*BG 709 : endif 710 : 711 : * Le nb total de légendes à afficher, ici majoré par le nb de courbes, 712 : * est compris entre NLGMIN et NLGMAX 713 : * Première légende en haut 714 : NNLG = MAX(NLGMIN,MIN(INBEVO,NLGMAX)) 715 : c write(6,*) 'NLGMIN,MAX,INBEVO,NNLG=',NLGMIN,NLGMAX,INBEVO,NNLG 716 : HAUT = 1. 717 : IF (NLG.LT.NLGMAX) THEN 718 : 719 : * on incrémente les compteurs de courbes avec legende 720 : NCT = NCT + 1 721 : NLG = NLG + 1 722 : 723 : * position Y pour les cas NO et NE 724 : if(IPOSI.le.2) then 725 : TYY = YSUP + ((1.D0-NLG)*(DYEVL/NNLG)) 726 : & - (.05*DYEVL) 727 : * position Y pour les cas SO, SE 728 : elseif(IPOSI.le.4) then 729 : TYY = YINF + ((NLG-1.D0)*(DYEVL/NNLG)) 730 : & + (.05*DYEVL) 731 : * position YPOSI fourni par l utilisateur 732 : elseif(IPOSI.eq.6) then 733 : IF(ZLOGY) THEN 734 : YPOS1 = LOG10(YPOSI) 735 : ELSE 736 : YPOS1 = YPOSI 737 : ENDIF 738 : TYY = YPOS1 + ((1.D0-NLG)*(DYEVL/NNLG)) 739 : & - (.03*DYEVL) 740 : * position Y pour le cas t EXT 741 : else 742 : TYY = YINF + ((NLG-1.D0)*(DYEVL/NNLG)) 743 : & + (.03*DYEVL) 744 : cbp : contrairement a ce qui est ecrit la 1ere legende est en bas ! 745 : c TYY = YINF + ((NNLG-NLG)*(DYEVL/NNLG)) 746 : c & + (.03*DYEVL) 747 : endif 748 : 749 : * un petit bout de remplissage éventuellement 750 : TDY=0. 751 : IF (ZREMP) THEN 752 : TDY=.01*DYEVL 753 : TRX(1)= XPOS1 + (.06*BREF) 754 : TRY(1)= TYY - TDY 755 : TRX(2)= XPOS1 + (.30*BREF) 756 : TRY(2)= TYY - TDY 757 : TRX(3)= XPOS1 + (.30*BREF) 758 : TRY(3)= TYY + TDY 759 : TRX(4)= XPOS1 + (.06*BREF) 760 : TRY(4)= TYY + TDY 760 : CALL TRFACE(4,TRX,TRY,TRZ,1.,NLOCAB,IEFF) 761 : ENDIF 762 : 763 : * un petit bout de ligne éventuellement 764 : IF (.NOT. ZNOLI) THEN 765 : TX(1)= XPOS1 + (.06*BREF) 766 : TX(2)= XPOS1 + (.30*BREF) 767 : TY(1)= TYY + TDY 768 : TY(2)= TYY + TDY 768 : IF (ZREMP) CALL CHCOUL(ICOMBR) 768 : CALL TRSEG (IPTR1,TX,TY,ZTIRET,KTIR,DL,ZTRAC) 768 : IF (ZREMP) CALL CHCOUL(NLOCAB) 769 : ENDIF 770 : 771 : * le marqueur/label éventuel 772 : IF ((IMARQ.NE.0).OR.ZLABEL.OR.(ZNOLI.AND..NOT.ZREMP)) THEN 773 : TXX = XPOS1 + (.18*BREF) 774 : TYY2 = TYY + TDY 775 : 776 : IF (IMARQ.EQ.0) THEN 777 : IMARQ=1 778 : IEPAI=1 779 : XTAIL=1D0 780 : ZPLEIN=.FALSE. 781 : ENDIF 782 : 782 : IF (ZLABEL) CALL TRLABL(TXX,TYY2,0.,MLABEL,72,HMIN) 782 : CALL DMARQ(IPTR1,TXX,TYY2,IMARQ,XTAIL,ZPLEIN,NLOCAB) 783 : ENDIF 784 : 785 : * et le texte, un poil plus bas 786 : TXX2 = XPOS1 + (.33*BREF) 787 : TYY2 = TYY - (.01*DYEVL) 787 : CALL TRLABL (TXX2,TYY2,0.,TITOPT(1:20),20,HMIN) 788 : 789 : ENDIF 790 : ENDIF 791 : * 792 : SEGDES MLREE1,MLREEL,KEVOLL 793 : * 794 : END 795 : 796 : 797 : 798 : 799 : 800 : 801 : 802 : 803 : 804 : 805 :
© Cast3M 2003 - All rights reserved.
Disclaimer