C TREVOL SOURCE GOUNAND 26/01/09 21:16:05 12443 SUBROUTINE TREVOL (IPTR1,IPTR2,CHAINE,TITOPT,ZLEGE,NCT,NLG,INBEVO & ,IPOSI,XPOSI,YPOSI,ZREMP2,IDEB1,IFIN1,ISTYL) *============================================================= * Modifications : * * 95/02/07 Loca * passer les legendes x et y de 12 à 20 caractères: * SEGMENT AXE disparait et est appelé en include: -INC TMAXE. * * 2004 Maugis * Légendes à partir du haut, avec un espacement dépendant de leur nombre * Possibilité de ne pas écrire de légende pour une courbe donnée * * 05 sept. 2007 Maugis * Affichage de marqueurs aussi lorsqu'ils sont sur un bord * Maintien du segment AXE actif en modification * Mise du point en premier type de marqueur * Ajout de formes de marqueurs, dont 2 autres triangles TRIL et TRIR * pointant horizontalement, on garde pour compatibilité TRIA et TRIB, * qui peuvent maintenant être invoqués avec TRID et TRIU * respectivement. * Correction de tracé (ou absence de tracé) illicite avec REGU * avec marqueurs aux extrémités * *============================================================= * * Entrée : * * IPTR1 : POINTEUR SUR UN AXE (ACTIF) * IPTR2 : POINTEUR SUR UN KEVOLL * CHAINE : MOT CONTENANT LES OPTIONS SPECIFIQUES * ZLEGE : INDIQUE QUE L'ON EST EN MODE LEGENDE DES COURBES * NCT : NUMERO A AFFICHER SUR LA COURBE * NLG : NOMBRE DE LÉGENDES À AFFICHER AU TOTAL * INBEVO : NOMBRE TOTAL D'EVOLUTIONS * IPOSI position predefinie de la legende * XPOSI, YPOSI = position XY de la legende fourni par l utilisateur * *============================================================= * * TOUTES LES VARIABLES COMMENCANT PAR T SONT EN SIMPLE PRECISION ! * * MMT : MOT EXTRAIT DE CHAINE * ZREGU : REPERE ESPACE REGULIEREMENT * ZTIRET : TIRET ENTRE POINTS * ZNOLI : ABSENCE DE LIGNE ENTRE POINT * ZLABEL : ECRITURE D'EN LABEL * ZPLEIN : Le marqueur doit être rempli * LTAIL : TABLE des tailles * XTAIL : facteur multiplicatif de taille du marqueur * IEPAI : facteur multiplicatif (entier) de l'épaisseur des traits du marqueur * IMARQ : NUMERO DE LA FORME DU MARQUEUR (=0 <=> PAS DE MARQUEUR) * NMARQ : NOMBRE DE FORMES POSSIBLES DE MARQUEURS * LMARQ : TABLE DES MARQUEURS * NREGU : NOMBRE DE MARQUEURS PAR COURBE EN DISPOSITION REGULIERE * NLGMIN : NOMBRE MINIMAL DE LEGENDES * NLGMAX : NOMBRE MAXIMAL DE LEGENDES * INB : NOMBRE DE POINTS A TRAITER * ZREMP2 : logique indiquant le remplissage sous une des courbes * (false en entree) * *============================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-S,U-Y) C*? IMPLICIT REAL*4 (T) IMPLICIT LOGICAL (Z) * -INC SMEVOLL -INC SMLREEL -INC SMLENTI POINTEUR MLENT0.MLENTI -INC TMAXE -INC CCREEL -INC PPARAM -INC CCOPTIO -INC CCTRACE C Gestion des LISTENTI dans les EVOLUTIONS PARAMETER (NLIST=3) CHARACTER*(8) CLIST(NLIST),CTYP DATA CLIST /'LISTREEL','LISTENTI','LISTMOTS'/ MACRO , (LISTREEL , LISTENTI , LISTMOTS) * EXTERNAL LONG PARAMETER (NREGU=8,NLGMIN=19,NLGMAX=30,NMARQ=15,NCLEF=10,NTAIL=7) REAL HMIN,TYYM REAL*8 IEPAI CHARACTER*(*) CHAINE,TITOPT CHARACTER*(LOCHAI) CHVIDE,MLABEL CHARACTER*12 MMT,FMMT CHARACTER*4 LMARQ(NMARQ),LCLEF(NCLEF),LTAIL(NTAIL) C CHARACTER CC DIMENSION TX(2),TY(2) DIMENSION TRX(6),TRY(6),TRZ(6) * on garde TRIA et TRIB pour compatibilité DATA LMARQ /'POIN','CROI','PLUS','ETOI','CARR','LOSA', & 'TRIA','TRIB','TRIL','TRIR','TRID','TRIU', & 'MOIN','BARR','ROND'/ DATA LCLEF /'REGU','NOLI','TIRR','TIRC','TIRL','TIRM','MARQ', & 'REMP','POIN','BLAN'/ C Taille SS remplacer par XS, conservee pour compatibilite jdd DATA LTAIL /'XS ','S ','M ','L ','XL ','XXL ','SS '/ * Valeurs par défaut XGPOS = 1.D0*XSGRAN XGNEG = -1.D0*XSGRAN XGPET = XSPETI ZREGU = .FALSE. ZNOLI = .FALSE. ZTIRET = .FALSE. KTIR = 0 ZLABEL = .FALSE. IMARQ = 0 ZPLEIN = .FALSE. XTAIL = 1.D0 IEPAI = 1.D0 CHVIDE =' ' ZREMP = .FALSE. ZBLANC= .FALSE. XMINT= XSGRAN YMINT= XSGRAN XMAXT=-XSGRAN YMAXT=-XSGRAN DO I=1,5 TRZ(I)=0. ENDDO IF (ICOSC.EQ.1) THEN ICOMBR=7 ELSE ICOMBR=8 ENDIF * * ==================================================================== * TRAITEMENT DES OPTIONS * ==================================================================== * IF (CHAINE .NE.CHVIDE) THEN I=1 1 CONTINUE CALL EXTRAC (CHAINE,I,MMT) IF (MMT.NE.CHVIDE) THEN CALL PLACE(LCLEF,NCLEF,ICLEF,MMT(1:4)) * 'REGU' IF (ICLEF.EQ.1) ZREGU=.TRUE. * 'NOLI' IF (ICLEF.EQ.2) ZNOLI=.TRUE. * 'TIRR'/'TIRC'/'TIRL'/'TIRM' / 'POIN' IF (ICLEF.EQ.3) THEN ZTIRET=.TRUE. KTIR=1 ENDIF IF (ICLEF.EQ.4) THEN ZTIRET=.TRUE. KTIR=2 ENDIF IF (ICLEF.EQ.5) THEN ZTIRET=.TRUE. KTIR=3 ENDIF IF (ICLEF.EQ.6) THEN ZTIRET=.TRUE. KTIR=4 ENDIF IF (ICLEF.EQ.9) THEN ZTIRET=.TRUE. KTIR=5 ENDIF * 'MARQ' IF (ICLEF.EQ.7) THEN * La présence de ce mot-clef réinitialise les options de * marqueur, pour le cas de spécifications successives ZPLEIN = .FALSE. XTAIL = 1.D0 IEPAI = 1.D0 IMARQ = 0 20 CALL EXTRAC(CHAINE,I,MMT) * remplir le marqueur ? IF (MMT(1:4).EQ.'PLEI') THEN ZPLEIN = .TRUE. GOTO 20 ENDIF * taille du marqueur CALL PLACE(LTAIL,NTAIL,ITAIL,MMT(1:4)) * write(6,*) ' taille du marqueur ' , itail IF (ITAIL.NE.0) THEN IF (ITAIL.EQ.1) XTAIL = 0.25D0 IF (ITAIL.EQ.2) XTAIL = 0.50D0 IF (ITAIL.EQ.3) XTAIL = 1.00D0 IF (ITAIL.EQ.4) XTAIL = 1.25D0 IF (ITAIL.EQ.5) XTAIL = 1.75D0 IF (ITAIL.EQ.6) XTAIL = 2.50D0 IF (ITAIL.EQ.7) XTAIL = 0.25D0 C IF (ITAIL.EQ.7) THEN ** spécification d'une taille arbitraire ** (la croix et la banière pour convertir en flottant!) * CALL EXTRAC(CHAINE,I,MMT) * LMMT = LONG(MMT) * WRITE(cc,FMT='(I1)') LMMT * FMMT = '(I'//cc//')' * READ(MMT,FMT=FMMT(1:4)) I1 * XTAIL = I1 C ENDIF GOTO 20 ENDIF * épaisseur de ligne (entre 0 et 9) IF (MMT(1:4).EQ.'EPAI') THEN CALL EXTRAC(CHAINE,I,MMT) READ(MMT,FMT='(I1)') IEPAI GOTO 20 ENDIF * type de marqueur (en dernier) CALL PLACE(LMARQ,NMARQ,IMARQ,MMT(1:4)) * write(6,*) ' type du marqueur ' , imarq IF (IMARQ.EQ.0) THEN * On ne comprend pas le mot %M moterr= MMT CALL ERREUR(7) ENDIF ENDIF * 'REMP' IF (ICLEF.EQ.8) THEN ZREMP=.TRUE. ZREMP2=.TRUE. ENDIF * 'BLAN' (pour un remplissage par du blanc) IF (ICLEF.EQ.10) ZBLANC = .TRUE. * 'LABEL' IF (MMT(1:4).EQ.'LABE') THEN ZLABEL=.TRUE. CALL EXTRAC(CHAINE,I,MLABEL) ENDIF IF (I.LE.72) GOTO 1 ENDIF ENDIF * AXE =IPTR1 KEVOLL=IPTR2 CTYP =KEVOLL.TYPX CALL PLAMO8(CLIST,NLIST,IPLACX,CTYP) IF(IPLACX .EQ. 0)THEN MOTERR=CTYP CALL ERREUR(39) RETURN ENDIF CASE, IPLACX WHEN, LISTREEL MLREEL=KEVOLL.IPROGX inb =MLREEL.PROG(/1) WHEN, LISTENTI MLENT0=KEVOLL.IPROGX inb =MLENT0.LECT(/1) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CTYP =KEVOLL.TYPY CALL PLAMO8(CLIST,NLIST,IPLACY,CTYP) IF(IPLACY .EQ. 0)THEN MOTERR=CTYP CALL ERREUR(39) RETURN ENDIF CASE, IPLACY WHEN, LISTREEL MLREE1=KEVOLL.IPROGY WHEN, LISTENTI MLENT1=KEVOLL.IPROGY WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE c Cas TRES particulier : IF (INB.LE.0) ZREGU = .FALSE. HMIN = .2 DXEVL = XSUP-XINF DYEVL = YSUP-YINF DL = DXEVL/100.D0 ZTRAC =.TRUE. IF (ZLOGY) THEN YZERO = YINF ELSE YZERO = MIN(MAX(0.D0,YINF),YSUP) ENDIF c IF (NUMEVY.EQ.'HIST') ZREMP=.TRUE. c ontrace entre les points IDEB et IFIN IDEB4=MAX(1,IDEB1) IFIN4=MIN(inb,IFIN1) c eventuel style de LIGNE_VARIABLE via un listentier c (=0 pour une ligne, 1 pour TIRR, ... 5 pour POINtille cf. KTIR) MLENTI=ISTYL IF(ISTYL.GT.0) THEN SEGACT,MLENTI c petite verif de dimension IF(LECT(/1).LT.IFIN4-1) THEN WRITE(IOIMP,*) 'dimension de LIGNE_VARIABLE =',(LECT(/1)) c On attend un objet de type %M1:8 de dimension %i1 INTERR=IFIN4-1 MOTERR='LISTENTI' CALL ERREUR(1018) RETURN ENDIF ENDIF c on sauvegarde la valeur par defaut KTIR0=KTIR c write(*,*) KTIR,KTIR0,ISTYL * * ==================================================================== * TRACE DE BASE * ==================================================================== * nlocab=numevx CALL CHCOUL(Nlocab) * * On rajoute cette étiquette pour gérer le fait que dans certains * cas (histogrammes par exemple), il faut tracer la totalité des * remplissages avant de tracer les segments, sinon ils seront * recouverts ZNOLI1=ZNOLI ZREMP1=ZREMP IF (.NOT.ZNOLI.AND.ZREMP) ZNOLI1=.TRUE. 30 CONTINUE cbp : on va faire le travail pour espacement REGU des marqueurs ici IF (ZREGU) THEN xlonx=(xsup-xinf)**2 xlony=(ysup-yinf)**2 xlong=0.d0 jg=inb-1 segini,MLREE2 ENDIF *==== BOUCLE SUR LES SEGMENTS ========================================= cbp DO 4 I = 1,inb-1 DO 4 I = IDEB4,IFIN4-1 * *-------CALCUL COORDONNEES (CORRIGEES SI LOG)------- c -recup CASE, IPLACX WHEN, LISTREEL X1=MLREEL.PROG(I) X2=MLREEL.PROG(I+1) WHEN, LISTENTI X1=FLOAT(MLENT0.LECT(I)) X2=FLOAT(MLENT0.LECT(I+1)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL Y1=MLREE1.PROG(I) Y2=MLREE1.PROG(I+1) WHEN, LISTENTI Y1=FLOAT(MLENT1.LECT(I)) Y2=FLOAT(MLENT1.LECT(I+1)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE c write(6,*) 'i=',i,X1,Y1,' - ',X2,Y2 * -Si un point est un Nan alors on ne trace pas ce segment IF(((X1.LT.0.D0).EQV.(X1.GE.0.D0)).OR. & ((Y1.LT.0.D0).EQV.(Y1.GE.0.D0)).OR. & ((X2.LT.0.D0).EQV.(X2.GE.0.D0)).OR. & ((Y2.LT.0.D0).EQV.(Y2.GE.0.D0))) THEN IF(IERPER.GE.3) GOTO 4 MOTERR='EVOLUTIO' CALL ERREUR(1012) IF(IERR.NE.0) RETURN GOTO 4 ENDIF * Evite les ieee_denormal et ieee_underflow if (abs(x1).LE.XGPET) x1=xzero if (abs(x2).LE.XGPET) x2=xzero if (abs(y1).LE.XGPET) y1=xzero if (abs(y2).LE.XGPET) y2=xzero c -coordonnee X IF (ZLOGX) THEN c on verifie qu'on n'a pas des infinis (si YBOR précisé par ex.) if(X1.le.0.D0.and.X2.le.0.d0) goto 4 if(X1.gt.0.D0) then TX(1) = LOG10(X1) else c cas segment horizontal avec 1er point infini TX(1) = XINF TY(1) = TY(2) endif if(X2.gt.0.D0) then TX(2) = LOG10(X2) else c cas segment horizontal avec 2eme point infini TX(2) = XINF TY(2) = TY(1) endif ELSE c cas points 1 et 2 infinis => on saute car segment non défini if(X1.gt.XGPOS.and.X2.gt.XGPOS) goto 4 if(X1.lt.XGNEG.and.X2.lt.XGNEG) goto 4 TX(1) = X1 TX(2) = X2 if(X1.gt.XGPOS) then c cas segment horizontal avec 1er point +infini TX(1) = XSUP TY(1) = TY(2) elseif(X1.lt.XGNEG) then c cas segment horizontal avec 1er point -infini TX(1) = XINF TY(1) = TY(2) endif if(X2.gt.XGPOS) then c cas segment horizontal avec 2eme point infini TX(2) = XSUP TY(2) = TY(1) elseif(X2.lt.XGNEG) then c cas segment horizontal avec 2eme point -infini TX(2) = XINF TY(2) = TY(1) endif ENDIF c -coordonnee Y IF (ZLOGY) THEN c on verifie qu'on n'a pas des infinis (si YBOR précisé par ex.) c cas points 1 et 2 infinis => on saute car segment non défini if(Y1.le.0.D0.and.Y2.le.0.d0) goto 4 if(Y1.gt.0.D0) then TY(1) = LOG10(Y1) else c cas segment vertical avec 1er point infini TX(1) = TX(2) TY(1) = YINF endif if(Y2.gt.0.D0) then TY(2) = LOG10(Y2) else c cas segment vertical avec 2eme point infini TX(2) = TX(1) TY(2) = YINF endif ELSE c cas points 1 et 2 infinis => on saute car segment non défini if(Y1.gt.XGPOS.and.Y2.gt.XGPOS) goto 4 if(Y1.lt.XGNEG.and.Y2.lt.XGNEG) goto 4 TY(1) = Y1 TY(2) = Y2 if(Y1.gt.XGPOS) then c cas segment vertical avec 1er point +infini TX(1) = TX(2) TY(1) = YSUP elseif(Y1.lt.XGNEG) then c cas segment vertical avec 1er point -infini TX(1) = TX(2) TY(1) = YINF endif if(Y2.gt.XGPOS) then c cas segment vertical avec 2eme point +infini TX(2) = TX(1) TY(2) = YPOS elseif(Y2.lt.XGNEG) then c cas segment vertical avec 2eme point -infini TX(2) = TX(1) TY(2) = YINF endif ENDIF c write(6,*) '->',i,TX(1),TY(1),' - ',TX(2),TY(2) *-------CALCUL DES EXTREMA DE LA COURBE------- IF (XMINT.EQ.XSGRAN) THEN XMINT = TX(1) XMAXT = TX(1) YMINT = TY(1) YMAXT = TY(1) ENDIF xtx2 = TX(2) yty2 = ty(2) XMINT = MIN (XMINT,xtx2) XMAXT = MAX (XMAXT,xtx2) YMINT = MIN (YMINT,yTY2) YMAXT = MAX (YMAXT,yTY2) * *-------POUR CHAQUE SEGMENT : ON VERIFIE S'IL APPARAIT DANS LA FENETRE-- * * -SEGMENT HORS FENETRE ? * attention : il faut éventuellement le "remplir" quand même -> goto 41 XMAX=MAX(TX(1),TX(2)) XMIN=MIN(TX(1),TX(2)) * XMAX trop a gauche IF (XMAX.LE.XINF) THEN IF(XMIN.LT.XINF) GOTO 4 * si XMAX=XMIN=XINF, on trace le segment sur le cadre ENDIF * XMIN trop a droite IF (XMIN.GE.XSUP) THEN IF(XMAX.GT.XSUP) GOTO 4 ENDIF YMAX=MAX(TY(1),TY(2)) YMIN=MIN(TY(1),TY(2)) * YMAX trop bas IF (YMAX.LE.YINF) THEN IF(YMIN.LT.YINF) GOTO 41 ENDIF * YMIN trop haut IF (YMIN.GE.YSUP) THEN IF(YMAX.GT.YSUP) GOTO 41 ENDIF * * * -EXTREMITE 1 DANS LA FENETRE ? IF((TX(1).GE.XINF).AND.(TX(1).LE.XSUP).AND. $ (TY(1).GE.YINF).AND.(TY(1).LE.YSUP)) GOTO 5 * * -EXTREMITE 2 DANS LA FENETRE ? IF((TX(2).GE.XINF).AND.(TX(2).LE.XSUP).AND. $ (TY(2).GE.YINF).AND.(TY(2).LE.YSUP)) GOTO 5 * * si on est là (et pas en 5), c'est qu' * -AUCUNE EXTREMITE DANS LA FENETRE MAIS SEGMENT SECANT * Cas segment vertical IF (TX(1).EQ.TX(2)) THEN IF ((TX(1).GT.XINF).AND.(TX(1).LT.XSUP)) THEN GOTO 5 ELSE GOTO 4 ENDIF ENDIF * Cas segment non vertical A = (TY(2)-TY(1)) / (TX(2)-TX(1)) IF (ABS(A).LT.1D-10) A=0.D0 Y = A * (XINF-TX(1))+TY(1) * Cas segment horizontal IF (A.EQ.0.D0) THEN IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) THEN GOTO 5 ELSE GOTO 41 ENDIF ENDIF IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) GOTO 5 Y=A*(XSUP-TX(1))+TY(1) IF ((Y.LT.YSUP) .AND. (Y.GT.YINF)) GOTO 5 X=TX(1)+(YINF-TY(1))/A IF ((X.LT.XSUP) .AND. (X.GT.XINF)) GOTO 5 X=TX(1)+(YSUP-TY(1))/A IF ((X.LT.XSUP) .AND. (X.GT.XINF)) GOTO 5 GOTO 41 *-------AU MOINS UN POINT DANS LA FENETRE------- 5 CONTINUE * Cas segment vertical IF (TX(1).EQ.TX(2)) THEN IF (TY(1).LE.YINF) TY(1)=YINF IF (TY(2).GE.YSUP) TY(2)=YSUP * Pas besoin de tracer le remplissage éventuel ! GOTO 51 ENDIF * (DBLE pour empecher une erreur de compilation sur certaines machines...) IF (ZREMP1) THEN TRX(1)=MIN(MAX(DBLE(TX(1)),XINF),XSUP) TRY(1)=MIN(MAX(DBLE(TY(1)),YINF),YSUP) TRX(2)=MIN(MAX(DBLE(TX(2)),XINF),XSUP) TRY(2)=MIN(MAX(DBLE(TY(2)),YINF),YSUP) ENDIF * * LINEARISE LE PREMIER POINT EN X IF (TX(1).LT.XINF) CALL LINEAX (TX,TY,XINF,1) IF (TX(1).GT.XSUP) CALL LINEAX (TX,TY,XSUP,1) * * LINEARISE LE PREMIER POINT EN Y IF (TY(1).LT.YINF) CALL LINEAX (TY,TX,YINF,1) IF (TY(1).GT.YSUP) CALL LINEAX (TY,TX,YSUP,1) * * LINEARISE LE SECOND POINT EN X IF (TX(2).LT.XINF) CALL LINEAX (TX,TY,XINF,2) IF (TX(2).GT.XSUP) CALL LINEAX (TX,TY,XSUP,2) * * LINEARISE LE SECOND POINT EN Y IF (TY(2).LT.YINF) CALL LINEAX (TY,TX,YINF,2) IF (TY(2).GT.YSUP) CALL LINEAX (TY,TX,YSUP,2) c write(6,*) 'lineax:',TX(1),TY(1),' - ',TX(2),TY(2) IF (ZREMP1) THEN NP=4 DO II=1,2 JJ=II+NP-4 IF (TX(II).NE.TRX(JJ).OR.TY(II).NE.TRY(JJ)) THEN NP=NP+1 TRX(NP-2)=TRX(NP-3) TRY(NP-2)=TRY(NP-3) TRX(NP-3)=TX(II) TRY(NP-3)=TY(II) ENDIF ENDDO TRX(NP-1)=TRX(NP-2) TRX(NP) =TRX(1) TRY(NP-1)=YZERO TRY(NP) =YZERO * trace du remplissage if (ZBLANC) then CALL TRFACE(NP,TRX,TRY,TRZ,1.,ICOMBR,IEFF) * bp: apres un tracé dans une couleur differente, * il faut toujours revenir a celle de la courbe CALL CHCOUL(NLOCAB) else CALL TRFACE(NP,TRX,TRY,TRZ,1.,NLOCAB,IEFF) endif ENDIF 51 CONTINUE c dans tous les cas sauf option 'NOLI' IF (.NOT.ZNOLI1) THEN * tracé du segment IF (ZREMP.and..not.ZBLANC) CALL CHCOUL(ICOMBR) * cas des styles de LIGNE_VARIABLE IF(ISTYL.GT.0) THEN KTIR=LECT(I) IF(KTIR.GT.5) KTIR=KTIR0 ZTIRET=KTIR.GE.1 ENDIF CALL TRSEG (IPTR1,TX,TY,ZTIRET,KTIR,DL,ZTRAC) IF (ZREMP.and..not.ZBLANC) CALL CHCOUL(NLOCAB) * Ni ligne, ni remplissage, ni marqueur => marqueur par défaut cbp : bizarre car non compatible avec REGU... => pour eviter de passer cbp ici, l utilisateur doit preciser ce qu'il veut (LIGN ou MARQ ...) ELSEIF (IMARQ.EQ.0.AND..NOT.ZREMP1) THEN * tracé du point + le 2e si dernier segment CALL DMARQ(IPTR1,TX(1),TY(1),1,1D0,.FALSE.,0) IF (I.EQ.(INB-1)) & CALL DMARQ(IPTR1,TX(2),TY(2),1,1D0,.FALSE.,0) ENDIF cbp : on calcule la longueur de la courbe xlong ici IF (ZREGU) THEN X2=(TX(2)-TX(1))**2 Y2=(TY(2)-TY(1))**2 xll=sqrt(X2/xlonx+Y2/xlony) xlong=xlong+sqrt(X2/xlonx+Y2/xlony) MLREE2.PROG(I)=xlong ENDIF GOTO 4 * LABEL 41 : *-----LE SEGMENT N'EST PAS DANS LA FENETRE, MAIS SON REMPLISSAGE PEUT Y ETRE 41 CONTINUE IF (ZREMP1) THEN TRX(1)=MIN(MAX(DBLE(TX(1)),XINF),XSUP) TRY(1)=MIN(MAX(DBLE(TY(1)),YINF),YSUP) TRX(2)=MIN(MAX(DBLE(TX(2)),XINF),XSUP) TRY(2)=MIN(MAX(DBLE(TY(2)),YINF),YSUP) * Finalement, le segment projete son remplissage hors de la fenetre... IF (TX(1).EQ.TX(2).AND.TY(1).EQ.TY(2)) GOTO 4 * ... ou alors le remplissage est d'epaisseur nulle IF (TRY(1).EQ.YZERO) GOTO 4 TRX(3)=TRX(2) TRX(4)=TRX(1) TRY(3)=YZERO TRY(4)=YZERO * tracé du remplissage if (ZBLANC) then CALL TRFACE(4,TRX,TRY,TRZ,1.,ICOMBR,IEFF) CALL CHCOUL(NLOCAB) else CALL TRFACE(4,TRX,TRY,TRZ,1.,NLOCAB,IEFF) endif ENDIF 4 CONTINUE *==== FIN DE LA BOUCLE SUR LES SEGMENTS DE LA COURBE ================== IF (.NOT.ZNOLI.AND.ZREMP) THEN ZNOLI1=.NOT.ZNOLI1 ZREMP1=.NOT.ZREMP1 IF (.NOT.ZREMP1) GOTO 30 ENDIF * * ==================================================================== * TRACE DU NOM DE LA COURBE (pour les HISTogrammes avec une legende) * ==================================================================== *bp,2019 CALL LENCHA(NOMEVY,LC) CALL LENCHA(KEVTEX,LC) IF (NUMEVY.EQ.'HIST'.AND.LC.GT.0) THEN TDELTX=ABS(XSUP-XINF)/45 TDELTY=ABS(YSUP-YINF)/45 BORX1=MAX(XINF,XMINT) BORX2=MIN(XSUP,XMAXT) TXX=0.5*(BORX1+BORX2) TXX2=TXX-0.125*TDELTX*LC * ajout bp,2019 pour afficher choisir le marqueur * -si TRIU : legende + TRIU en dessous de la courbe IF(IMARQ.EQ.12) THEN BORY2=MAX(YINF,YMINT) TYY=BORY2-TDELTY * il faut prendre en compte la taille de police (difficile) TYY2=TYY-2.0*TDELTY * -si TRID (par defaut) : legende + TRID au dessus de la courbe ELSEIF(IMARQ.EQ.11) THEN BORY2=MIN(YSUP,YMAXT) TYY=BORY2+TDELTY TYY2=TYY+TDELTY ENDIF IF (IMARQ.EQ.11.OR.IMARQ.EQ.12) THEN CALL DMARQ (IPTR1,TXX,TYY,IMARQ,XTAIL,.FALSE.,NLOCAB) HMIN=0.2 *bp,2019 CALL TRLABL(TXX2,TYY2,0.,NOMEVY,LC,HMIN) CALL TRLABL(TXX2,TYY2,0.,KEVTEX,LC,HMIN) ENDIF ENDIF * * ==================================================================== * TRACE DE MARQUEURS OU DE LABEL * ==================================================================== * * write(6,*)'iepai xtail zplein,nlocab',iepai,xtail,zplein,nlocab c IF ((IMARQ.NE.0).OR.ZLABEL) THEN *bp,2019 : on enleve cette option pour les histogrammes IF (((IMARQ.NE.0).OR.ZLABEL).and.NUMEVY.NE.'HIST')THEN * * EN CHAQUE POINT * IF (.NOT. ZREGU) THEN cbp DO 6 I=1,INB DO 6 I=IDEB4,IFIN4 CASE, IPLACX WHEN, LISTREEL XVAL=MLREEL.PROG(I) WHEN, LISTENTI XVAL=FLOAT(MLENT0.LECT(I)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL YVAL=MLREE1.PROG(I) WHEN, LISTENTI YVAL=FLOAT(MLENT1.LECT(I)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF (ZLOGX) THEN TXX=LOG10(XVAL) ELSE TXX=XVAL ENDIF IF (ZLOGY) THEN TYY=LOG10(YVAL) ELSE TYY=YVAL ENDIF * tracé si à peu près dans fenêtre IF ((TXX-XINF.GE.-XZPREC*DXEVL) .AND. & (TXX-XSUP.LE. XZPREC*DXEVL) .AND. & (TYY-YINF.GE.-XZPREC*DYEVL) .AND. & (TYY-YSUP.LE. XZPREC*DYEVL)) THEN IF (ZLABEL) & CALL TRLABL(TXX,TYY,0.,MLABEL,72,HMIN) IF (IMARQ.NE.0) THEN CALL DMARQ(IPTR1,TXX,TYY,IMARQ,XTAIL, & ZPLEIN,NLOCAB) ENDIF ENDIF 6 CONTINUE ENDIF * * RÉGULIÈREMENT * * write(6,*) ' nregu' , nregu IF (ZREGU) THEN * * calcul de la longueur de la courbe xlong * cbp : fait + haut c xlonx=(xsup-xinf)**2 c xlony=(ysup-yinf)**2 c xlong=0.d0 c IF(ZLOGX) THEN c XX=LOG10(PROG(1)) c ELSE c XX=PROG(1) c ENDIF c IF(ZLOGY) THEN c YY=LOG10(MLREE1.PROG(1)) c ELSE c YY=MLREE1.PROG(1) c ENDIF c c on restreint les points de la courbe a l'intervalle borné c XX=MIN(xsup,MAX(xinf,XX)) c YY=MIN(ysup,MAX(yinf,YY)) c do iy=2,prog(/1) c IF(ZLOGX) THEN c X1=LOG10(PROG(iy)) c ELSE c X1=PROG(iy) c ENDIF c IF(ZLOGY) THEN c Y1=LOG10(MLREE1.PROG(iy)) c ELSE c Y1=MLREE1.PROG(iy) c ENDIF c c on restreint les points de la courbe a l'intervalle borné c X1=MIN(xsup,MAX(xinf,X1)) c Y1=MIN(ysup,MAX(yinf,Y1)) c X2=(X1-XX)**2 c XX=X1 c Y2=(Y1-YY)**2 c YY=Y1 c xll=sqrt(X2/xlonx+Y2/xlony) c c write(6,*) 'segment',iy,' ->',xll c xlong=xlong+sqrt(X2/xlonx+Y2/xlony) c enddo npart=nregu xlongp= xlong / npart c write(6,*) 'xinf,xsup,yinf,ysup=',xinf,xsup,yinf,ysup c write(6,*) 'xlong,nregu,xlongp=',xlong,nregu,xlongp * * tracé des marqueurs régulièrement espacés * xmar=xlongp/2.d0 xdes=xlongp/10. xloo= 0.D0 c IF (ZLOGX) THEN c XX = LOG10(PROG(1)) c ELSE c XX = PROG(1) c ENDIF c IF (ZLOGY) THEN c YY = LOG10(MLREE1.PROG(1)) c ELSE c YY = MLREE1.PROG(1) c ENDIF c c on restreint les points de la courbe a l'intervalle borné c XX=MIN(xsup,MAX(xinf,XX)) c YY=MIN(ysup,MAX(yinf,YY)) cbp do iy=2,prog(/1) do iy=IDEB4+1,IFIN4 CASE, IPLACX WHEN, LISTREEL XVAL=MLREEL.PROG(iy) WHEN, LISTENTI XVAL=FLOAT(MLENT0.LECT(iy)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL YVAL=MLREE1.PROG(iy) WHEN, LISTENTI YVAL=FLOAT(MLENT1.LECT(iy)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF(ZLOGX) THEN X1=LOG10(XVAL) ELSE X1=XVAL ENDIF IF(ZLOGY) THEN Y1=LOG10(YVAL) ELSE Y1=YVAL ENDIF TXX=X1 TYY=Y1 c c on restreint les points de la courbe a l'intervalle borné c c pour le calcul de la longueur xloo c X1=MIN(xsup,MAX(xinf,X1)) c Y1=MIN(ysup,MAX(yinf,Y1)) c X2=(X1-XX)**2 c XX=X1 c Y2=(Y1-YY)**2 c YY=Y1 c xloo=xloo+sqrt ( x2/xlonx+y2/xlony) xloo=MLREE2.PROG(iy-1) * tracé si on a cumulé une longueur xmar if(xloo.gt.xmar)then * et si à peu près dans fenêtre IF ((TXX-XINF.GE.-XZPREC*DXEVL) .AND. & (TXX-XSUP.LE. XZPREC*DXEVL) .AND. & (TYY-YINF.GE.-XZPREC*DYEVL) .AND. & (TYY-YSUP.LE. XZPREC*DYEVL)) THEN IF (ZLABEL) & CALL TRLABL(TXX,TYY,0.,MLABEL,72,HMIN) IF (IMARQ.NE.0) THEN CALL DMARQ(IPTR1,TXX,TYY,IMARQ,XTAIL, & ZPLEIN,NLOCAB) ENDIF ENDIF 999 continue xmar=xmar+xlongp c si on a deja depassé xmar+xdes il faut aller chercher + loin if(xloo.gt.xmar+xdes) then c write(ioimp,*) ' on saute un point' go to 999 endif endif enddo segsup,MLREE2 ENDIF * fin du cas RÉGULIÈREMENT * * 9 CONTINUE ENDIF * * ==================================================================== * TRACÉ DE LA LÉGENDE AUPRÈS D'UN ÉCHANTILLON DE LIGNE * ==================================================================== * IF (ZLEGE.AND.(TITOPT(1:14).NE.'PAS DE LEGENDE')) THEN * on positionne la legende par rapport XPOS1 YPOS1 * definis en fonction de IPOSI * position X pour les cas NO et SO if(IPOSI.eq.1.or.IPOSI.eq.3) then XPOS1 = XINF + (.06*BG) BREF = 4.*BG endif * position X pour les cas NE et SE if(IPOSI.eq.2.or.IPOSI.eq.4) then c rem BP: On positionne pour etre OK avec la police de la sortie PS c et tant pis pour l ecran (par defaut opti poli '8_BY_13';) if(ZCARRE) then BREF = 0.72*BD else BREF = 4.*BD endif if(IOPOTR.le.3) then XPOS1 = XSUP - (0.95*BREF) elseif(IOPOTR.le.6) then XPOS1 = XSUP - (1.05*BREF) elseif(IOPOTR.le.9) then XPOS1 = XSUP - (1.15*BREF) else XPOS1 = XSUP - (1.25*BREF) endif endif * position X pour le cas EXT if(IPOSI.eq.5) then XPOS1 = XSUP BREF = BD endif * position XPOSI fourni par l utilisateur if(IPOSI.eq.6) then IF(ZLOGX) THEN XPOS1 = LOG10(XPOSI) ELSE XPOS1 = XPOSI ENDIF BREF = 4.*BG endif * Le nb total de légendes à afficher, ici majoré par le nb de courbes, * est compris entre NLGMIN et NLGMAX * Première légende en haut NNLG = MAX(NLGMIN,MIN(INBEVO,NLGMAX)) c write(6,*) 'NLGMIN,MAX,INBEVO,NNLG=',NLGMIN,NLGMAX,INBEVO,NNLG HAUT = 1. IF (NLG.LT.NLGMAX) THEN * on incrémente les compteurs de courbes avec legende NCT = NCT + 1 NLG = NLG + 1 * position Y pour les cas NO et NE if(IPOSI.le.2) then TYY = YSUP + ((1.D0-NLG)*(DYEVL/NNLG)) & - (.05*DYEVL) * position Y pour les cas SO, SE elseif(IPOSI.le.4) then TYY = YINF + ((NLG-1.D0)*(DYEVL/NNLG)) & + (.05*DYEVL) * position YPOSI fourni par l utilisateur elseif(IPOSI.eq.6) then IF(ZLOGY) THEN YPOS1 = LOG10(YPOSI) ELSE YPOS1 = YPOSI ENDIF TYY = YPOS1 + ((1.D0-NLG)*(DYEVL/NNLG)) & - (.03*DYEVL) * position Y pour le cas t EXT else TYY = YINF + ((NLG-1.D0)*(DYEVL/NNLG)) & + (.03*DYEVL) cbp : contrairement a ce qui est ecrit la 1ere legende est en bas ! c TYY = YINF + ((NNLG-NLG)*(DYEVL/NNLG)) c & + (.03*DYEVL) endif * un petit bout de remplissage éventuellement TDY=0. IF (ZREMP.and..not.ZBLANC) THEN TDY=.01*DYEVL TRX(1)= XPOS1 + (.06*BREF) TRY(1)= TYY - TDY TRX(2)= XPOS1 + (.30*BREF) TRY(2)= TYY - TDY TRX(3)= XPOS1 + (.30*BREF) TRY(3)= TYY + TDY TRX(4)= XPOS1 + (.06*BREF) TRY(4)= TYY + TDY CALL TRFACE(4,TRX,TRY,TRZ,1.,NLOCAB,IEFF) ENDIF * un petit bout de ligne éventuellement IF (.NOT. ZNOLI) THEN TX(1)= XPOS1 + (.06*BREF) TX(2)= XPOS1 + (.30*BREF) TY(1)= TYY + TDY TY(2)= TYY + TDY IF (ZREMP.and..not.ZBLANC) CALL CHCOUL(ICOMBR) c write(*,*) 'legende',KTIR0 ZTIRET=KTIR0.GE.1 CALL TRSEG (IPTR1,TX,TY,ZTIRET,KTIR0,DL,ZTRAC) IF (ZREMP.and..not.ZBLANC) CALL CHCOUL(NLOCAB) ENDIF * le marqueur/label éventuel IF ((IMARQ.NE.0).OR.ZLABEL.OR.(ZNOLI.AND..NOT.ZREMP)) THEN TXX = XPOS1 + (.18*BREF) TYY2 = TYY + TDY IF (IMARQ.EQ.0) THEN IMARQ=1 IEPAI=1 XTAIL=1D0 ZPLEIN=.FALSE. ENDIF IF (ZLABEL) CALL TRLABL(TXX,TYY2,0.,MLABEL,72,HMIN) CALL DMARQ(IPTR1,TXX,TYY2,IMARQ,XTAIL,ZPLEIN,NLOCAB) ENDIF * et le texte, un poil plus bas TXX2 = XPOS1 + (.33*BREF) TYY2 = TYY - (.01*DYEVL) CALL TRLABL (TXX2,TYY2,0.,TITOPT(1:72),72,HMIN) ENDIF ENDIF END