C DESSIN SOURCE OF166741 25/02/20 21:16:01 12165 SUBROUTINE DESSIN *============================================================= * * Dessine une evolution * *============================================================= * * Modifications * * 95/02/07, Loca : * pour passer les legendes x et y de 12 a 20 caracteres: * SEGMENT AXE disparait et est appele en include: -INC TMAXE. * * 03/03/14, maugis : * correction de la position du logo en cas de zoom. * * 07/09/04, maugis : * fourniture du choix des courbes via un LISTENTI * Maintien du segment AXE actif en modification * Resolution pb de zoom en logarithmique avec des valeurs * inferieures a 0. * Resolution erreur 497 quand 2 clics zoom hors cadre * *============================================================= * * LISTE DES FONCTIONS : * * MINMAX : RETOURNE MINI ET MAXI D'UN LISTREEL ou LISTENTI * BORAXE : CALCUL DES ARRONDIS DE BORNES D'AXES * INTAXE : CALCUL POUR EFFECTUER LA GRADUATION * DAXES : DESSIN DES AXES * ICALP : FONCTION POUR CALCUL DES BORNES D'AXES * TREVOL : DESSIN D'UNE EVOLUTION * TRSEG : TRACE DUN SEGMENT DE DROITE * EXTRAC : EXTRACTION D'UN MOT DANS UNE CHAINE * LINEAX : LINEARISATION EN X * LINEAY : LINEARISATION EN Y * DMARQ : DESSINE DES MARQUEURS * TRCUR : TRACER DES NOMS EN CAS D'ABSCISSE CURVILIGNE * TRINIT ET SES FONCTIONS (definies selon la sortie graphique) * *============================================================= * * LISTE DES VARIABLES : * * --- affichage interactif --- * BMIN,BMAX HAUTEUR DE CARACTERE POUR LES E/S GRAPHIQUES * BUFFER(X) CHAINE DE CARACTERE POUR LES E/S * TX,TY TABLES POUR DESSINER UN INDEX L'AIDE DE POLRL * TXX(X),TYY(X) POSITION POUR LES E/S DES BUFFERS * ZINDEX INDEX SUR COURBE * ZLIEN LIEN SUR UN COMMENTAIRE * * --- axe --- * AXE SEGMENT AXE DE TMAXE.INC * OLDAXE AXE DE SAUVEGARDE POUR RETOUR APRES UN ZOOM * IPOSX, IPOSY position predefinie du titre des axes X, Y * XINT YINT GRADUATION ELEMENTAIRE DES AXES X, Y * ZLOGX, ZLOGY AXE X, Y EN LOG * ZXFORC, ZYFORC BORNES SUR L'AXE X, Y IMPOSEES * ZXGRA, ZYGRA graduation sur l'axe X, Y imposee * * --- calcul, divers --- * YMAXI MAXIMUM EN Y SUR L'ENSEMBLE DES EVOLUTIONS * YMINI MINIMUM EN Y SUR L'ENSEMBLE DES EVOLUTIONS * ZMIMA AFFICHAGE DU MINIMUM ET DU MAXIMUM * ZARR SYSTEME D'ARRONDI NON NORMALISE * ZDATE AFFICHAGE DE LA DATE * ZHEURE AFFICHAGE DE L'HEURE (CB : Option plus disponible on dirait) * ZLOGO DESSIN DU LOGO * * --- general --- * IPTR POINTEUR UTILISE POUR EVITER LES PBS ESOPE DUS A * L'ECHANGE D'ARGUMENTS INCLUS DANS DES SEGMENTS * NOL NUMERO D'ORDRE LOGIQUE DE LA FENETRE * XDIM,YDIM PARAMETRES POUR TABT (TAILLE PAPIER) * ZSEPAR TRACE SEPARE DES COURBES * * --- evolutions courbes --- * IEV POINTEUR D'EVOLUTION * INBEVO NOMBRE TOTAL D'EVOLUTIONS * NC NUMERO DE L'EVOLUTION QUE L'ON TRAITE (OPTION SEPA) * ZCUR TABLE INDIQUANT LES EVOLUTIONS CONTENANT DES NOMS * D'ABSCISSES ou d'ordonnees * ZOPTIO EXISTENCE D'UNE TABLE D'OPTION SPECIFIQUE * ZTRACE TABLE INDIQUANT LES COURBES A TRACER * * --- legende --- * IPOSI position predefinie de la legende * NCT NUMERO DE COURBE A TRACER AVEC LEGENDE SUR UN MEME GRAPHE * NLG COMPTEUR DE LEGENDES AFFICHABLES (NON VIDES) * XPOSI, YPOSI position XY de la legende fourni par l utilisateur * ZLEGEN AJOUT DES LEGENDES EN FIN DE COURBE * * --- options graphiques --- * IOPTIO POINTEUR SUR LA TABLE DES OPTIONS SPECIFIQUES * LPARAM LISTE DES PARAMETRES GENERAUX NPARAM NOMBRE DE PARAMETRES * ZAXES TRACE DES AXES OX ET OY * ZCARRE FENETRE CARREE + axes "EQUAL" depuis 2015-12-04 * ZGRILL AFFICHAGE D'UNE GRILLE * * --- titre --- * HTITRE HAUTEUR DU TITRE * TITRE TITRE GLOBAL DE L'EVOLUTION * * --- nuage --- * ZNUAG VRAI SI NUAGE, FAUX SI EVOLUTIONS * * * TOUTES LES VARIABLES COMMENCANT PAR T SONT EN SIMPLE PRECISION ! * *============================================================= * * REMARQUES : * * - TOUTES LES VARIABLES EN T SONT DES REELS SIMPLE PRECISION * POUR COMMUNIQUER AVEC TRINIT * - JE JOUE SUR LA COULEUR 8 POUR EFFACER DU TEXTE * - CHAQUE TRBOX CHANGEANT LA TAILLE DES CARACTERES EST SUIVI PAR * UN TRBOX RAMENANT A L'ETAT INITIAL * - LE SYSTEME DE LECTURE DES VALEURS N'EST PAS SUPER * ARRONDI DE LA MACHINE * INTERACTIVITE PEU CONVIVIAL (SANS DEVLPT. DE DEPENDANT * MACHINE) * PAS IMPLEMENTE EN GKS * *============================================================= IMPLICIT LOGICAL (Z) IMPLICIT INTEGER (I-N) IMPLICIT REAL*8 (A-H,O-S,U-Y) C Liste des objets traites par DESS dans les KEVOLL PARAMETER (NLIST=3) CHARACTER*(8) CLIST(NLIST) DATA CLIST /'LISTREEL','LISTENTI','LISTMOTS'/ MACRO , (LISTREEL , LISTENTI , LISTMOTS) * -INC PPARAM -INC CCOPTIO -INC CCREEL -INC SMEVOLL -INC SMNUAGE -INC SMLREEL POINTEUR MLREEX.MLREEL,MLREEY.MLREEL -INC SMLENTI POINTEUR MLENTX.MLENTI,MLENTY.MLENTI -INC CCGEOME -INC TMAXE -INC CCTRACE REAL LIEN(10,5) * REAL RXDIM,RYDIM,HMIN,TCENTX,TCENTY,HTLOG dimension TZ(10) * LOGICAL VALEUR CHARACTER*13 LEGEND(8),CARDX,CARDY CHARACTER*8 CTYP POINTEUR OLDAXE.AXE * SEGMENT COM CHARACTER*30 COMMENT(10) REAL TXCOM(10),TYCOM(10) INTEGER ICOUCO(10) ENDSEGMENT * TABLEAU DE LOGIQUE GERE EN DYNAMIQUE SEGMENT DYN LOGICAL ZTRACE(NDIMT) ENDSEGMENT SEGMENT CUR LOGICAL ZCUR(NDIMT2) ENDSEGMENT * DIMENSION TX(2),TY(2) CHARACTER*(LOCHAI) TITRE,TXTIT,BUFFER,TMPCAR CHARACTER*18 BUFFER1,BUFFER2,BUFFER3,BUFFER4 CHARACTER*8 CTYPE,CHVIDE,ETYPE PARAMETER (NPARAM=24) cegal PARAMETER (NPARAM=25) CHARACTER*4 LPARAM(NPARAM) CHARACTER*20 TXAXE,TYAXE CHARACTER*4 MOPOSI(8),MOPOSX(2),MOGRIL(6),MOGRIS(1) CHARACTER*8 MOFMT * DATA LPARAM/'LOGX','LOGY','XBOR','YBOR','CARR','SEPA','GRIL', # 'MIMA','LEGE','DATE','CHOI','NARR','LOGO','TITR', # 'TITX','TITY','AXES','NCLK','XGRA','YGRA', # 'POSX','POSY','XFMT','YFMT'/ cegal # 'POSX','POSY','XFMT','YFMT','EGAL'/ DATA MOPOSI/'NO ','NE ','SO ','SE ','EXT ','XY ', # 'NW ','SW '/ DATA MOPOSX/'EXCE','CENT'/ DATA MOGRIL/'LIGN','TIRR','TIRC','TIRL','TIRM','POIN'/ DATA MOGRIS/'GRIS'/ ************************************************************************ * INITIALISATIONS ************************************************************************ CB Mise a zero de LIEN : ATTENTION REAL*4 DO II=1,5 DO JJ=1,10 LIEN(JJ,II)=0. ENDDO ENDDO TLACX=0. TLACY=0. DO II=1,10 TZ(II) = 0 ENDDO KCLICK = 1 TXTIT = ' ' TXAXE = ' ' TYAXE = ' ' BUFFER = ' ' ICOM = 0 IBON = 0 ICOLOG = IDCOUL INDCOU = IDCOUL HDPLOG = 1. HTLOG = 1. PASSE = 0. XUN = 1.D0 * * CREE L'AXE COURANT ET SA SAUVEGARDE * SEGINI AXE OLDAXE=0 MXFMT(1:8)=' ' MYFMT(1:8)=' ' c SEGINI OLDAXE cbp : on le fait + loin SEGINI COM DYN=0 CUR=0 * ETYPE(1:8)='ENTIER ' * CHVIDE(1:8)=' ' * * INITIALISATION DES LOGIQUES ASSOCIES AUX PARAMETRES * ZLOGX = .FALSE. ZLOGY = .FALSE. ZCARRE = .FALSE. ZLEGEN = .FALSE. ZSEPAR = .FALSE. ZDATE = .FALSE. ZGRILL = .FALSE. * ZHEURE = .FALSE. (CB : plus diponible apparement) ZMIMA = .FALSE. ZLOGO = .FALSE. ZOPTIO = .FALSE. ZXFORC = .FALSE. ZYFORC = .FALSE. ZARR = .FALSE. ZAXES = .FALSE. ZINDEX = .FALSE. ZLOGOO = .FALSE. ZVALEUR= .FALSE. ZLIEN = .FALSE. ZXGRA = .FALSE. ZYGRA = .FALSE. * ZNUAG = .FALSE. (CB : On ne s'en sert pas en realite...) ZEGAL = .FALSE. NHIST=0 MEVOLL=0 ************************************************************************ * LECTURE DE L'EVOLUTION (ou NUAGE) ************************************************************************ * * CHARGE L'EVOLUTION * CALL LIROBJ('EVOLUTIO',IEV,0,IOK) IF (IERR.NE.0) GOTO 1000 * * ou le NUAGE D'EVOLUTIONs * IF (IOK.EQ.0) THEN CALL LIROBJ('NUAGE',INUAG,0,IOK) c write(*,*) 'Nuage lu ?',IOK,INUAG IF (IOK.EQ.1) THEN CALL ACTOBJ('NUAGE',INUAG,1) * ZNUAG=.TRUE. * verif du nuage : MNUAGE=INUAG NVAR=NUAPOI(/1) c write(*,*) 'Nuage constitue de ',NVAR,' n-uplets' IF(NVAR.NE.2) THEN WRITE(IOIMP,*) 'le Nuage doit contenir 2 n-uplets' CALL ERREUR(21) GOTO 1000 ENDIF IF(((NUATYP(1)(1:3)).NE.'MOT'.AND. & (NUATYP(1)(1:6)).NE.'ENTIER'.AND. & NUATYP(1).NE.'FLOTTANT').OR.NUATYP(2).NE.'EVOLUTIO') THEN WRITE(IOIMP,*) 'le Nuage doit contenir 2 n-uplets de type' WRITE(IOIMP,*) 'FLOTTANT et EVOLUTION' CALL ERREUR(21) GOTO 1000 ENDIF * pour simplifier la suite, on met les evolutions du nuage dans * une macro evolution : NUAVIN=NUAPOI(2) NBCOUP=NUAINT(/1) N=NBCOUP SEGINI,MEVOLL IEV=MEVOLL IEVTEX(1:8)=NUANOM(2) DO IBCOUP=1,NBCOUP MEVOL1=NUAINT(IBCOUP) IF(MEVOL1.IEVOLL(/1).NE.1) THEN WRITE(IOIMP,*) 'le Nuage doit contenir des evolutions simples' CALL ERREUR(25) GOTO 1000 ENDIF IEVOLL(IBCOUP)=MEVOL1.IEVOLL(1) ENDDO c write(*,*) 'les evolutions sont :',(IEVOLL(iou),iou=1,NBCOUP) ELSE MOTERR(1:40)=' ' MOTERR(1:16)='EVOLUTIONUAGE' CALL ERREUR(471) GOTO 1000 ENDIF ENDIF * * OUVERTURE ET TRAITEMENT DE L'EVOLUTION CHAPEAU * (titre et nombre de sous-evolutions) CALL ACTOBJ('EVOLUTIO',IEV,1) MEVOLL = IEV c valeur prise par TITRE par ordre de priorite : c 1. = TXTIT = valeur fournie apres le mot cle 'TITR' de c l'instruction DESS (cf. optdes.eso) c 2. = valeur de la commande TITRE (TITREE du CCOPTIO) c 3. = IEVTEX de l'evolution (=valeur de TITREE lors de la creation c de l'evolution) --> possible seulement si TITREE du CCOPTIO c a ete reinitialise a ' ' c TITRE = ' ' TITRE=IEVTEX IF(TITREE.NE.' ') TITRE=TITREE c nombre total de sous-evolutions INBEVO = IEVOLL(/1) IF (INBEVO.EQ.0) GOTO 1000 * * DEFINITION TAILLE CARACTERE * * HMIN=.2 * * DIMENSIONNE LA TABLE ZTRACE + ZCUR * NDIMT=INBEVO SEGINI DYN NDIMT2=INBEVO SEGINI CUR * * INITIALISATION TABLE ZTRACE * DO 1 I=1,INBEVO ZTRACE(I)=.TRUE. 1 CONTINUE ************************************************************************ * LECTURE DES OPTIONS ************************************************************************ * * CHARGEMENT DES PARAMETRES GENERAUX OPTIONNELS * 2 CONTINUE CALL LIRMOT(LPARAM,NPARAM,INDICE,0) IF (INDICE.NE.0) THEN GOTO (3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, $ 221,222,223,224,225,226),INDICE cegal $ 221,222,223,224,225,226,71),INDICE * * LOGX : SELECTION ECHELLE LOG EN X * 3 CONTINUE ZLOGX=.TRUE. GOTO 2 * * LOGY : SELECTION ECHELLE LOG EN Y * 4 CONTINUE ZLOGY=.TRUE. GOTO 2 * * XBOR : BORNES AXE X IMPOSEES * 5 CONTINUE ZXFORC=.TRUE. CALL LIRREE(XXX,1,IOK) IF (IERR.NE.0) GOTO 1000 XINF=XXX CALL LIRREE (XXX,1,IOK) IF (IERR.NE.0) GOTO 1000 XSUP=XXX GOTO 2 * * YBOR : BORNES AXE Y IMPOSEES * 6 CONTINUE ZYFORC=.TRUE. CALL LIRREE(XXX,1,IOK) IF (IERR.NE.0) GOTO 1000 YINF=XXX CALL LIRREE (XXX,1,IOK) IF (IERR.NE.0) GOTO 1000 YSUP=XXX GOTO 2 * * CARR : FENETRE CARREE * depuis 2015-12-04, CARR : FENETRE CARREE + AXES "EQUAL" * 7 CONTINUE cegal ZCARRE=.TRUE. cegal GOTO 2 cegal* cegal* EGAL : FENETRE CARREE + AXES "EQUAL" cegal* cegal 71 CONTINUE ZCARRE=.TRUE. ZEGAL =.TRUE. GOTO 2 * * SEPA : TRACES SEPARES * 8 CONTINUE ZSEPAR=.TRUE. GOTO 2 * * GRIL : UTILISATION D'UNE GRILLE SUR LES AXES EN LOG OU EN LINEAIRE * 9 CONTINUE ZGRILL=.TRUE. c type de tiret ou de pointille CALL LIRMOT(MOGRIL,6,IGRIL,0) if(IGRIL.eq.0) IGRIL=1 c couleur noir ou grise? CALL LIRMOT(MOGRIS,1,IGRIS,0) if(IGRIS.ne.0) IGRIL=-1*IGRIL GOTO 2 * * MIMA : AFFICHAGE MINIMUM MAXIMUM * 10 CONTINUE ZMIMA=.TRUE. GOTO 2 * * LEGE : AFFICHAGE LEGENDE EN BOUT DE COURBE * 11 CONTINUE ZLEGEN=.TRUE. * POSITION DE LA LEGENDE CALL LIRMOT(MOPOSI,8,IPOSI,0) * PAR DEFAUT EXT <=> POSLEG=5 if(IPOSI.eq.0) IPOSI=5 * XY suivi de la position dans le graphique if(IPOSI.eq.6) then CALL LIRREE(XPOSI,1,IRETX) CALL LIRREE(YPOSI,1,IRETY) IF(IRETX.EQ.0.OR.IRETY.EQ.0) & write(ioimp,*) 'LEGE XY doit etre suivi de Xlege Ylege !' IF (IERR.NE.0) GOTO 1000 endif * NW et SW sont en fait NO et SO en anglais if(IPOSI.eq.7) IPOSI=1 if(IPOSI.eq.8) IPOSI=3 * FORCE CARRE POUR AVOIR LA PLACE D'AFFICHER LES LEGENDES if(IPOSI.eq.5) ZCARRE=.TRUE. GOTO 2 * * DATE : AFFICHAGE DATE * 12 CONTINUE ZDATE=.TRUE. GOTO 2 * * CHOI : SELECTION DE COURBE * 13 CONTINUE * * MET A FAUX TOUTES LES SELECTIONS DE TRACES * DO 85 I=1,INBEVO ZTRACE(I)=.FALSE. ZCUR(I) =.FALSE. 85 CONTINUE *PM A-t-on un ENTIER, un LISTENTI ou rien en entree ? CALL QUETYP (CTYP,0,IRETOU) IF (IRETOU.EQ.0) GOTO 2 IF (CTYP.EQ.'ENTIER ') THEN IOK = 1 DO WHILE (IOK.EQ.1) CALL LIRENT (IXX,0,IOK) IF (IOK.EQ.1) ZTRACE(IXX) = .TRUE. ENDDO ENDIF IF (CTYP.EQ.'LISTENTI') THEN CALL LIROBJ('LISTENTI',ILENTI,1,IRET) IF (IRET.NE.1) RETURN MLENTI = ILENTI SEGACT, MLENTI DO I=1,LECT(/1) IXX = LECT(I) ZTRACE(IXX) = .TRUE. ENDDO ENDIF GOTO 2 * * NARR : GRADUATION NON NORMALISEE * 14 CONTINUE ZARR=.TRUE. GOTO 2 * * LOGO : DESSIN DU LOGO * 15 CONTINUE ZLOGO =.TRUE. ZLOGOO=.TRUE. GOTO 2 * * TITR : AFFICHAGE D'UN TITRE GENERAL * 16 CONTINUE CALL LIRCHA(TXTIT,0,IRETOU) IF (IRETOU.EQ.0) TXTIT=' ' GOTO 2 * * TITX : AFFICHAGE D'UN TITRE EN X * 17 CONTINUE CALL LIRCHA(TXAXE,0,IRETOU) IF (IRETOU.EQ.0) TXAXE=' ' GOTO 2 * * TITY : AFFICHAGE D'UN TITRE EN Y * 18 CONTINUE CALL LIRCHA(TYAXE,0,IRETOU) IF (IRETOU.EQ.0) TYAXE=' ' GOTO 2 * * AXES : TRACE DES AXES OX ET OY * 19 CONTINUE ZAXES=.TRUE. GOTO 2 * * NCLK : OPTION NOCLICK * 20 CONTINUE KCLICK=0 GOTO 2 * * XGRA et YGRA : GRADUATIONS IMPOSEES * 221 CONTINUE ZXGRA = .true. CALL LIRREE(XINT1,1,IOK) IF(IOK.EQ.0) write(ioimp,*)'XGRA doit etre suivi d un flottant' IF (IERR.NE.0) GOTO 1000 GOTO 2 * 222 CONTINUE ZYGRA = .true. CALL LIRREE(YINT1,1,IOK) IF(IOK.EQ.0) write(ioimp,*)'YGRA doit etre suivi d un flottant' IF (IERR.NE.0) GOTO 1000 GOTO 2 * * POSX et POSY : GRADUATIONS IMPOSEES * 223 CONTINUE CALL LIRMOT(MOPOSX,2,IIPOS,1) IF(IIPOS.EQ.0)write(ioimp,*)'POSX doit etre suivi d un mot-cle' IPOSX=IIPOS IF(IERR.NE.0) GOTO 1000 GOTO 2 * 224 CONTINUE CALL LIRMOT(MOPOSX,2,IIPOS,1) IF(IIPOS.EQ.0)write(ioimp,*)'POSY doit etre suivi d un mot-cle' IPOSY=IIPOS IF(IERR.NE.0) GOTO 1000 GOTO 2 * * XFMT et YFMT : FORMAT DES GRADUATIONS IMPOSEES * 225 CONTINUE CALL LIRCHA(MOFMT,1,IFMT) IF(IERR.NE.0) GOTO 1000 MXFMT(1:IFMT)=MOFMT if(iimpi.ge.1) write(IOIMP,*) 'MXFMT(1:',IFMT,')=',MXFMT(1:8) GOTO 2 * 226 CONTINUE CALL LIRCHA(MOFMT,1,IFMT) IF(IERR.NE.0) GOTO 1000 MYFMT(1:IFMT)=MOFMT if(iimpi.ge.1) write(IOIMP,*) 'MYFMT(1:',IFMT,')=',MYFMT(1:8) GOTO 2 * ENDIF * ************************************************************************ * LECTURE DE LA TABLE DES PARAMETRES SPECIFIQUES ************************************************************************ * CALL LIROBJ('TABLE',IOPTIO,0,IOK) IF (IOK.EQ.1) THEN ZOPTIO=.TRUE. ENDIF ************************************************************************ * * CONSTRUCTION DES COURBES DE TYPE HISTOGRAMME * On le fait après la lecture des options car la valeur min en Y * est soit 0., soit 1. avec l'option 'LOGY' * ************************************************************************ DO I0=1,INBEVO KEVOLL=IEVOLL(I0) IF (NUMEVY.EQ.'HIST') NHIST=NHIST+1 ENDDO IF (NHIST.NE.0) THEN SEGINI,MEVOL1=MEVOLL DO I0=1,INBEVO KEVOLL=IEVOLL(I0) SEGINI,KEVOL1=KEVOLL IF (NUMEVY.EQ.'HIST') THEN NHIST=NHIST+1 * CTYP =KEVOLL.TYPX CALL PLAMO8(CLIST,NLIST,IPLACX,CTYP) IF (IPLACX.EQ.LISTREEL) THEN MLREEX=KEVOLL.IPROGX JG=2*MLREEX.PROG(/1) SEGINI,MLREE1 C Remarque CB215821 : Aucune protection si MLREEX.PROG(/1) = 1 ... DO J0=1,MLREEX.PROG(/1) MLREE1.PROG(2*J0-1)=MLREEX.PROG(J0) MLREE1.PROG(2*J0 )=MLREEX.PROG(J0) ENDDO KEVOL1.IPROGX=MLREE1 ELSEIF (IPLACX.EQ.LISTENTI) THEN MLENTX=KEVOLL.IPROGX JG=2*MLENTX.LECT(/1) SEGINI,MLENT1 DO J0=1,MLENTX.LECT(/1) MLENT1.LECT(2*J0-1)=MLENTX.LECT(J0) MLENT1.LECT(2*J0 )=MLENTX.LECT(J0) ENDDO KEVOL1.IPROGX=MLENT1 ELSE KEVOL1.IPROGX=KEVOLL.IPROGX ENDIF * CTYP =KEVOLL.TYPY CALL PLAMO8(CLIST,NLIST,IPLACY,CTYP) IF (IPLACY.EQ.LISTREEL) THEN MLREEY=KEVOLL.IPROGY JG=2*MLREEY.PROG(/1) SEGINI,MLREE1 IF (ZLOGY) THEN MLREE1.PROG(1)=1.D0 ELSE MLREE1.PROG(1)=0.D0 ENDIF C Remarque CB215821 : Aucune protection sur la taille de MLREEX.PROG(/1) DO J0=1,MLREEY.PROG(/1)-1 MLREE1.PROG(2*J0 )=MLREEY.PROG(J0) MLREE1.PROG(2*J0+1)=MLREEY.PROG(J0) ENDDO IF (ZLOGY) THEN MLREE1.PROG(JG)=1.D0 ELSE MLREE1.PROG(JG)=0.D0 ENDIF KEVOL1.IPROGY=MLREE1 ELSEIF (IPLACY.EQ.LISTENTI) THEN MLENTY=KEVOLL.IPROGY JG=2*MLENTY.LECT(/1) SEGINI,MLENT1 IF (ZLOGY) THEN MLENT1.LECT(1)=1 ELSE MLENT1.LECT(1)=0 ENDIF C Remarque CB215821 : Aucune protection sur la taille de MLENTX.LECT(/1) DO J0=1,MLENTY.LECT(/1)-1 MLENT1.LECT(2*J0 )=MLENTY.LECT(J0) MLENT1.LECT(2*J0+1)=MLENTY.LECT(J0) ENDDO IF (ZLOGY) THEN MLENT1.LECT(JG)=1 ELSE MLENT1.LECT(JG)=0 ENDIF KEVOL1.IPROGY=MLENT1 ELSE KEVOL1.IPROGY=KEVOLL.IPROGY ENDIF MEVOL1.IEVOLL(I0)=KEVOL1 ENDIF ENDDO IEV=MEVOL1 ENDIF * ************************************************************************ * PAR DEFAUT, TITRE DES AXES = NOM DES X et Y DE LA 1ERE COURBE A TRACER ************************************************************************ * MEVOLL=IEV I=1 22 CONTINUE IF ((.NOT.ZTRACE(I)).AND.(I.LE.INBEVO)) THEN I=I+1 GOTO 22 ENDIF IF (I.GT.INBEVO) GOTO 1000 KEVOLL=IEVOLL(I) TITREX(1:20)=NOMEVX TITREY(1:20)=NOMEVY ************************************************************************ * TRAITEMENT DES OPTIONS QUI PEUVENT L'ETRE DES A PRESENT ************************************************************************ NC=0 * * DANS LE CAS DE BORNES IMPOSEES ON VERIFIE QUE LA BORNE SUPERIEURE EST * EFFECTIVEMENT PLUS PETITE QUE LA BORNE INFERIEURE * IF (ZXFORC.AND.XSUP.LT.XINF) GOTO 950 IF (ZYFORC.AND.YSUP.LT.YINF) GOTO 950 * * DANS LE CAS DE BORNES IMPOSEES EN LOG, ON VERIFIE * QU'ELLES NE SONT PAS NEGATIVES * IF (ZXFORC.AND.ZLOGX.AND.XINF.LT.XPETIT) GOTO 900 IF (ZYFORC.AND.ZLOGY.AND.YINF.LT.XPETIT) GOTO 900 * * TRIE LES EVOLUTIONS REFERANT DES NOMS D'ABSCISSES * (CAS DES ABSCISSES CURVILIGNES) * MEVOLL=IEV DO 23 I=1,INBEVO KEVOLL=IEVOLL(I) CTYP =KEVOLL.TYPX CALL PLAMO8(CLIST,NLIST,IPLACX,CTYP) IF(IPLACX .EQ. 0)THEN MOTERR=CTYP CALL ERREUR(39) RETURN ENDIF CTYP =KEVOLL.TYPY CALL PLAMO8(CLIST,NLIST,IPLACY,CTYP) IF(IPLACY .EQ. 0)THEN MOTERR=CTYP CALL ERREUR(39) RETURN ENDIF IF (IPLACX.EQ.LISTMOTS) THEN IF(IPLACY.EQ.LISTREEL .OR. IPLACY.EQ.LISTENTI)THEN ZTRACE(I)=.FALSE. ZCUR(I) =.TRUE. ELSE ZTRACE(I)=.FALSE. ZCUR(I) =.FALSE. ENDIF ENDIF IF (IPLACY.EQ.LISTMOTS) THEN IF(IPLACX.EQ.LISTREEL .OR. IPLACX.EQ.LISTENTI)THEN ZTRACE(I)=.FALSE. ZCUR(I) =.TRUE. ELSE ZTRACE(I)=.FALSE. ZCUR(I) =.FALSE. ENDIF ENDIF 23 CONTINUE *======================================================================= *==== CAS D'UN TRACE SIMULTANE (TOUTES LES COURBES) ==================== * IF (.NOT.ZSEPAR) THEN ************************************************************************ * CALCUL DES BORNES DES AXES SUR X ET SUR Y (TRACE SIMULTANE) ************************************************************************ IF (ZYFORC .AND.(.NOT.ZXFORC)) THEN * BORNES IMPOSEES SUR Y MAIS PAS SUR X XINF= XGRAND XSUP=-XGRAND DO 24 J=1,INBEVO * --- BOUCLE SUR LES EVOLUTIONS A TRACER --- IF (ZTRACE(J)) THEN KEVOLL=IEVOLL(J) 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 MLREEX=KEVOLL.IPROGX NG =MLREEX.PROG(/1) IF(NG .EQ. 0)GOTO 24 PGX1 =MLREEX.PROG(1) WHEN, LISTENTI MLENTX=KEVOLL.IPROGX NG =MLENTX.LECT(/1) IF(NG .EQ. 0)GOTO 24 PGX1 =FLOAT(MLENTX.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 MLREEY=KEVOLL.IPROGY PGY1 =MLREEY.PROG(1) WHEN, LISTENTI MLENTY=KEVOLL.IPROGY PGY1 =FLOAT(MLENTY.LECT(1)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF(ABS(PGX1) .LT. XPETIT) PGX1=0.D0 IF(ABS(PGY1) .LT. XPETIT) PGY1=0.D0 XTEST1=SIGN(XUN,(PGY1-YINF)) XTEST4=SIGN(XUN,(PGY1-YSUP)) IF(XTEST1.GT.0.D0 .AND. XTEST4.LT.0.D0 )THEN C Le points est compris entre YINF et YSUP XINF=MIN(XINF,PGX1) XSUP=MAX(XSUP,PGX1) ENDIF IF(NG .LT. 2)GOTO 24 DO 25 IG=2,NG CASE, IPLACX WHEN, LISTREEL PGX=MLREEX.PROG(IG) WHEN, LISTENTI PGX=FLOAT(MLENTX.LECT(IG)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL PGY=MLREEY.PROG(IG) WHEN, LISTENTI PGY=FLOAT(MLENTY.LECT(IG)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF(ABS(PGX) .LT. XPETIT) PGX=0.D0 IF(ABS(PGY) .LT. XPETIT) PGY=0.D0 XTEST2=SIGN(XUN,(PGY -YINF)) XTEST3=XTEST1*XTEST2 XTEST5=SIGN(XUN,(PGY -YSUP)) XTEST6=XTEST4*XTEST5 IF ((XTEST1.GT.0.D0 .AND. XTEST2.GT.0.D0) .AND. & (XTEST4.LT.0.D0 .AND. XTEST5.LT.0.D0))THEN C Les 2 points sont compris entre YINF et YSUP XINF=MIN(XINF,PGX1,PGX) XSUP=MAX(XSUP,PGX1,PGX) ELSEIF(XTEST3.LT.0.D0 .OR. XTEST6.LT.0.D0) THEN C Les 2 points sont de part en d'autre d'une des borne IF(XTEST3 .LT. 0.D0) THEN C Les 2 points sont de part en d'autre de YINF XTEST31=SIGN(XUN,(PGX-PGX1))*SIGN(XUN,(PGY-PGY1)) IF (XTEST31 .GT. 0.D0) THEN IOKMI=1 VMIN =YINF CALL INTEXT(PGY1,PGY,PGX1,PGX,VMIN) XINF =MIN(XINF,VMIN) XSUP =MAX(XSUP,VMIN) ELSE IOKMA=1 VMAX =YINF CALL INTEXT(PGY1,PGY,PGX1,PGX,VMAX) XINF =MIN(XINF,VMAX) XSUP =MAX(XSUP,VMAX) ENDIF ENDIF IF(XTEST6 .LT. 0.D0) THEN C Les 2 points sont de part en d'autre de YSUP XTEST61=SIGN(XUN,(PGX-PGX1))*SIGN(XUN,(PGY-PGY1)) IF (XTEST61.GT.0.D0) THEN IOKMA=1 VMAX =YSUP CALL INTEXT(PGY1,PGY,PGX1,PGX,VMAX) XINF =MIN(XINF,VMAX) XSUP =MAX(XSUP,VMAX) ELSE IOKMI=1 VMIN =YSUP CALL INTEXT(PGY1,PGY,PGX1,PGX,VMIN) XINF =MIN(XINF,VMIN) XSUP =MAX(XSUP,VMIN) ENDIF ENDIF C ELSE C Les 2 points sont inferieurs a la borne YINF 'OU' C Les 2 points sont superieurs a la borne YSUP ENDIF PGX1=PGX PGY1=PGY XTEST1=XTEST2 XTEST4=XTEST5 25 CONTINUE ENDIF 24 CONTINUE * --- FIN DE BOUCLE SUR LES EVOLUTIONS A TRACER --- IF(XINF.GT.0.D0 .AND. XSUP.LT.0.D0) THEN C Cas ou aucun point ne satisfait les bornes donnees XINF =-XUN XSUP = XUN ELSEIF(ABS(XSUP - XINF) .LT. & XZPREC*MAX(ABS(XSUP),ABS(XINF),XPETIT/XZPREC))THEN C Cas ou aucun 1 seul point satisfait les bornes donnees XINF = XINF - XUN XSUP = XSUP + XUN ENDIF ************************************************************************ ELSEIF (ZXFORC .AND.(.NOT.ZYFORC)) THEN * BORNES IMPOSEES SUR X MAIS PAS SUR Y YINF= XGRAND YSUP=-XGRAND DO 26 J=1,INBEVO * --- BOUCLE SUR LES EVOLUTIONS A TRACER --- IF (ZTRACE(J)) THEN KEVOLL=IEVOLL(J) 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 MLREEX=KEVOLL.IPROGX NG =MLREEX.PROG(/1) IF(NG .EQ. 0)GOTO 26 PGX1 =MLREEX.PROG(1) WHEN, LISTENTI MLENTX=KEVOLL.IPROGX NG =MLENTX.LECT(/1) IF(NG .EQ. 0)GOTO 26 PGX1 =FLOAT(MLENTX.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 MLREEY=KEVOLL.IPROGY PGY1 =MLREEY.PROG(1) WHEN, LISTENTI MLENTY=KEVOLL.IPROGY PGY1 =FLOAT(MLENTY.LECT(1)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF(ABS(PGX1) .LT. XPETIT) PGX1=0.D0 IF(ABS(PGY1) .LT. XPETIT) PGY1=0.D0 XTEST1=SIGN(XUN,(PGX1 - XINF)) XTEST4=SIGN(XUN,(PGX1 - XSUP)) IF(XTEST1.GT.0.D0 .AND. XTEST4.LT.0.D0 )THEN C Le points est compris entre XINF et XSUP YINF=MIN(YINF,PGY1) YSUP=MAX(YSUP,PGY1) ENDIF IF(NG .LT. 2)GOTO 26 DO 27 IG=2,NG CASE, IPLACX WHEN, LISTREEL PGX=MLREEX.PROG(IG) WHEN, LISTENTI PGX=FLOAT(MLENTX.LECT(IG)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL PGY=MLREEY.PROG(IG) WHEN, LISTENTI PGY=FLOAT(MLENTY.LECT(IG)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF(ABS(PGX) .LT. XPETIT) PGX=0.D0 IF(ABS(PGY) .LT. XPETIT) PGY=0.D0 XTEST2=SIGN(XUN,(PGX - XINF)) XTEST3=XTEST1*XTEST2 XTEST5=SIGN(XUN,(PGX - XSUP)) XTEST6=XTEST4*XTEST5 IF ((XTEST1.GT.0.D0 .AND. XTEST2.GT.0.D0) .AND. & (XTEST4.LT.0.D0 .AND. XTEST5.LT.0.D0))THEN C Les 2 points sont compris entre XINF et XSUP YINF=MIN(YINF,PGY1,PGY) YSUP=MAX(YSUP,PGY1,PGY) ELSEIF(XTEST3.LT.0.D0 .OR. XTEST6.LT.0.D0) THEN C Les 2 points sont de part en d'autre d'une des borne IF(XTEST3 .LT. 0.D0) THEN C Les 2 points sont de part et d'autre de XINF XTEST31=SIGN(XUN,(PGX-PGX1))*SIGN(XUN,(PGY-PGY1)) IF (XTEST31 .GT. 0.D0) THEN IOKMI=1 VMIN =XINF CALL INTEXT(PGX1,PGX,PGY1,PGY,VMIN) YINF =MIN(YINF,VMIN) YSUP =MAX(YSUP,VMIN) ELSE IOKMA=1 VMAX =XINF CALL INTEXT(PGX1,PGX,PGY1,PGY,VMAX) YINF =MIN(YINF,VMAX) YSUP =MAX(YSUP,VMAX) ENDIF ENDIF IF(XTEST6 .LT. 0.D0) THEN C Les 2 points sont de part en d'autre de XSUP XTEST61=SIGN(XUN,(PGX-PGX1))*SIGN(XUN,(PGY-PGY1)) IF (XTEST61.GT.0.D0) THEN IOKMA=1 VMAX =XSUP CALL INTEXT(PGX1,PGX,PGY1,PGY,VMAX) YINF =MIN(YINF,VMAX) YSUP =MAX(YSUP,VMAX) ELSE IOKMI=1 VMIN =XSUP CALL INTEXT(PGX1,PGX,PGY1,PGY,VMIN) YINF =MIN(YINF,VMIN) YSUP =MAX(YSUP,VMIN) ENDIF ENDIF C ELSE C Les 2 points sont inferieurs a la borne XINF 'OU' C Les 2 points sont superieurs a la borne XSUP ENDIF PGX1=PGX PGY1=PGY XTEST1=XTEST2 XTEST4=XTEST5 27 CONTINUE ENDIF 26 CONTINUE * --- FIN DE BOUCLE SUR LES EVOLUTIONS A TRACER --- IF(YINF.GT.0.D0 .AND. YSUP.LT.0.D0) THEN C Cas ou aucun point ne satisfait les bornes donnees YINF =-XUN YSUP = XUN ELSEIF(ABS(YSUP - YINF) .LT. & XZPREC*MAX(ABS(YSUP),ABS(YINF),XPETIT/XZPREC))THEN C Cas ou aucun 1 seul point satisfait les bornes donnees YINF = YSUP - XUN YSUP = YSUP + XUN ENDIF ************************************************************************ ELSEIF ((.NOT.ZXFORC).AND.(.NOT.ZYFORC)) THEN * PAS DE BORNES IMPOSEES I=0 28 CONTINUE I=I+1 IF (.NOT. ZTRACE(I)) GOTO 28 IF (I.GT.INBEVO) RETURN * * PREMIERE EVOLUTION : INITIALISATION Des MIN ET Des MAX * MEVOLL= IEV KEVOLL= IEVOLL(I) IPTR = KEVOLL.IPROGX CTYP = KEVOLL.TYPX C Gestion si liste abscisses de longeur nulle JG = -1 IF (CTYP.EQ.'LISTREEL') THEN MLREEL = IPTR JG = MLREEL.PROG(/1) ENDIF IF (CTYP.EQ.'LISTENTI') THEN MLENTI = IPTR JG = MLENTI.LECT(/1) ENDIF IF (JG.EQ.-1) THEN CALL ERREUR(39) RETURN ENDIF * write(6,*) 'dessin : JG=',JG IF (JG.EQ.0) GOTO 28 CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN XINF = AMINI XSUP = AMAXI IPTR = KEVOLL.IPROGY CTYP = KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN YINF=AMINI YSUP=AMAXI * write(ioimp,*) I,'ieme evol: X,Y=',XINF,XSUP,',',YINF,YSUP * * BOUCLE SUR LES AUTRES EVOLUTIONS A TRACER * IF (I.LT.INBEVO) THEN DO 29 J=I+1,INBEVO IF (ZTRACE(J)) THEN KEVOLL=IEVOLL(J) IPTR =KEVOLL.IPROGX CTYP =KEVOLL.TYPX CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN IF (IRET.EQ.0) GOTO 29 IF (AMINI.LT.XINF) XINF=AMINI IF (AMAXI.GT.XSUP) XSUP=AMAXI IPTR =KEVOLL.IPROGY CTYP =KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN IF (AMINI.LT.YINF) YINF=AMINI IF (AMAXI.GT.YSUP) YSUP=AMAXI * write(ioimp,*) J,'ieme evol: X,Y=',XINF,XSUP,',',YINF,YSUP ENDIF 29 CONTINUE ENDIF ************************************************************************ * ELSE * TOUTES LES BORNES SONT DONNEES 'XBOR' et 'YBOR' : Rien a faire ENDIF ************************************************************************ ************************************************************************ * CALCUL DES MINI MAXI (TRACE SIMULTANE) ************************************************************************ IF (ZMIMA) THEN * * SAUVEGARDE VALEUR AXE POUR CHERCHER MAXI * I=0 32 CONTINUE I=I+1 IF (.NOT. ZTRACE(I)) GOTO 32 * * PREMIERE EVOLUTION : INITIALISATION DU MIN ET DU MAX * MEVOLL=IEV KEVOLL=IEVOLL(I) IPTR =KEVOLL.IPROGY CTYP =KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN YMINI=AMINI YMAXI=AMAXI * * BOUCLE SUR LES AUTRES EVOLUTIONS A TRACER * DO 33 J=I+1,INBEVO IF (ZTRACE(J)) THEN KEVOLL=IEVOLL(J) IPTR =KEVOLL.IPROGY CTYP =KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN IF (AMINI.LT.YMINI) YMINI=AMINI IF (AMAXI.GT.YMAXI) YMAXI=AMAXI ENDIF 33 CONTINUE ENDIF ************************************************************************ * PETITS TRAVAUX SUR LES AXES X et Y (TRACE SIMULTANE) ************************************************************************ * * DANS LE CAS D'AXES EN LOG, * ON VERIFIE QUE LES BORNES NE SONT PAS NEGATIVES * IF (ZLOGX.AND.XINF.LT.XPETIT) GOTO 900 IF (ZLOGY.AND.YINF.LT.XPETIT) GOTO 900 * * CALCUL DES ARRONDIS, * Les bornes passent eventuellement en log10 * CALL BORAXE(XINF,XSUP,ZLOGX) CALL BORAXE(YINF,YSUP,ZLOGY) CALL INTPDO(IREP) IF(IREP .EQ. 2) IPOW=30 IF(IREP .EQ. 1) IPOW=62 XIMAX=REAL(2**IPOW) SXINF=SIGN(XUN,XINF) SYINF=SIGN(XUN,YINF) SXSUP=SIGN(XUN,XSUP) SYSUP=SIGN(XUN,YSUP) C CB : Passage de XSPETI et REAL*8 sinon plantage sur SEMT2 XSP_R8=XSPETI XCENT =100.D0 * XINF =SXINF*MIN(MAX(ABS(XINF),XSP_R8),XIMAX/XCENT) * YINF =SYINF*MIN(MAX(ABS(YINF),XSP_R8),XIMAX/XCENT) * XSUP =SXSUP*MIN(MAX(ABS(XSUP),XSP_R8),XIMAX/XCENT) * YSUP =SYSUP*MIN(MAX(ABS(YSUP),XSP_R8),XIMAX/XCENT) C SG 2021/03 : On ne voit pas la necessite de borner inferieurement C par XSP_R8 XINF =SXINF*MIN(ABS(XINF),XIMAX/XCENT) YINF =SYINF*MIN(ABS(YINF),XIMAX/XCENT) XSUP =SXSUP*MIN(ABS(XSUP),XIMAX/XCENT) YSUP =SYSUP*MIN(ABS(YSUP),XIMAX/XCENT) * * CALCUL DU PAS DE GRADUATION * c VERIFICATION COMPATIBILITE OPTION EQUAL ('EGAL') IF(ZEGAL) THEN XLON = XSUP-XINF YLON = YSUP-YINF XSURY = XLON / YLON c write(6,*) 'DESSIN EGAL :',XINF,XSUP,YINF,YSUP,'XSURY=',XSURY IF(ZLOGX.OR.ZLOGY) THEN cegal write(ioimp,*) 'Option EGAL incompatible avec LOGX, LOGY' write(ioimp,*) 'Option CARRE incompatible avec LOGX, LOGY' ZEGAL=.FALSE. ELSEIF(XSURY.GE.1.0D0.AND.ZYFORC.OR.ZYGRA) THEN cegal write(ioimp,*) 'Option EGAL incompatible avec YBOR, YGRA' write(ioimp,*) 'Option CARRE incompatible avec YBOR, YGRA' ZEGAL=.FALSE. ELSEIF(XSURY.LT.1.0D0.AND.ZXFORC.OR.ZXGRA) THEN cegal write(ioimp,*) 'Option EGAL incompatible avec XBOR, XGRA' write(ioimp,*) 'Option CARRE incompatible avec XBOR, XGRA' ZEGAL=.FALSE. ENDIF ENDIF c ---OPTION EQUAL ('EGAL') IF(ZEGAL) THEN IF(XSURY.GE.1.0D0) THEN * PAS DE GRADUATION en X CALL INTAXE(XINF,XSUP,XINT,INX,ZLOGX,ZARR.OR.ZXFORC) * PAS en Y = celui en X --> on change les bornes YINF et YSUP YINT=XINT YMIL=0.5D0*(YINF+YSUP) c write(6,*) 'DESSIN EGAL : X',XINT,INX,'YMIL=',YMIL 711 CONTINUE YINF=XINT*REAL(FLOOR(YINF/YINT+1.D-8)) YSUP=XINT*REAL(CEILING(YSUP/YINT-1.D-8)) INY = INT((YSUP-YINF)/YINT+5.D-3) c write(6,*) 'DESSIN EGAL :',XINF,XSUP,YINF,YSUP,INX,INY IF(INY.GT.INX) THEN c cas rare mais qu'il faut prevoir XMIL=0.5D0*(XINF+XSUP) IF(ABS(XMIL-XINF).GE.ABS(XSUP-XMIL)) THEN XSUP=XSUP+XINT ELSE XINF=XINF-XINT ENDIF INX = INX + 1 ELSEIF(INY.LT.INX) THEN c on cherche a avoir le meme nombre de graduations IF(ABS(YMIL-YINF).GE.ABS(YSUP-YMIL)) THEN YSUP=YSUP+YINT ELSE YINF=YINF-YINT ENDIF GOTO 711 ENDIF ELSE * PAS DE GRADUATION en Y CALL INTAXE(YINF,YSUP,YINT,INY,ZLOGY,ZARR.OR.ZYFORC) * PAS en X = celui en Y --> on change les bornes XINF et XSUP XINT=YINT XMIL=0.5D0*(XINF+XSUP) c write(6,*) 'DESSIN EGAL : Y',YINT,INY,'XMIL=',XMIL iterx=0 c write(6,*) 'DESSIN EGAL :',XINF,XSUP,YINF,YSUP,INX,INY 712 CONTINUE iterx=iterx+1 XINF=XINT*REAL(FLOOR(XINF/XINT+1.D-8)) XSUP=XINT*REAL(CEILING(XSUP/XINT-1.D-8)) INX = INT((XSUP-XINF)/XINT+5.D-3) c write(6,*) 'DESSIN EGAL :',XINF,XSUP,YINF,YSUP,INX,INY IF(INX.GT.INY) THEN c cas rare mais qu'il faut prevoir YMIL=0.5D0*(YINF+YSUP) IF(ABS(YMIL-YINF).GE.ABS(YSUP-YMIL)) THEN YSUP=YSUP+YINT ELSE YINF=YINF-YINT ENDIF INY = INY + 1 ELSEIF(INX.LT.INY) THEN c on cherche a avoir le meme nombre de graduations IF(ABS(XMIL-XINF).GE.ABS(XSUP-XMIL)) THEN XSUP=XSUP+XINT ELSE XINF=XINF-XINT ENDIF GOTO 712 ENDIF ENDIF c ---CAS non-EQUAL ELSE * PAS DE GRADUATION en X CALL INTAXE(XINF,XSUP,XINT,INX,ZLOGX,ZARR.OR.ZXFORC) if(ZXGRA) then if(ZLOGX) then write(ioimp,*) 'Option XGRA non compatible avec LOGX' else XINT=XINT1 INX=INT((XSUP-XINF)/XINT+5.D-3) endif endif * PAS DE GRADUATION en Y CALL INTAXE(YINF,YSUP,YINT,INY,ZLOGY,ZARR.OR.ZYFORC) if(ZYGRA) then if(ZLOGY) then write(ioimp,*) 'Option YGRA non compatible avec LOGY' else YINT=YINT1 INY=INT((YSUP-YINF)/YINT+5.D-3) endif endif ENDIF c ---FIN OPTION EQUAL ('EGAL') OU non-EQUAL ENDIF *==== CAS D'UN TRACE SIMULTANE (TOUTES LES COURBES) ==================== *======================================================================= * PREPARATION AU CAS D'UN TRACE SEPARE (COURBE PAR COURBE) * IF (ZSEPAR.AND.ZLOGX.AND.ZXFORC) THEN X1=XINF X2=XSUP ENDIF IF (ZSEPAR.AND.ZLOGY.AND.ZYFORC) THEN Y1=YINF Y2=YSUP ENDIF 34 CONTINUE *======================================================================= *==== CAS D'UN TRACE SEPARE (COURBE PAR COURBE) ======================== IF (ZSEPAR) THEN * ************************************************************************ * CALCUL DES BORNES DES AXES SUR X ET SUR Y (TRACES SEPARES) ************************************************************************ * 35 CONTINUE IF (ZLOGX.AND.ZXFORC) THEN XINF=X1 XSUP=X2 ENDIF IF (ZLOGY.AND.ZYFORC) THEN YINF=Y1 YSUP=Y2 ENDIF NC=NC+1 IF (NC.GT.INBEVO) GOTO 1000 IF (.NOT.ZTRACE(NC)) GOTO 35 MEVOLL=IEV KEVOLL=MEVOLL.IEVOLL(NC) * * SURCHARGE DES TITRES * TITREX(1:20)=NOMEVX TITREY(1:20)=NOMEVY IOKX=0 IF (ZXFORC.AND.ZYFORC) IOKX=1 * ******* BORNES IMPOSEES SUR Y MAIS PAS SUR X * IF(ZYFORC.AND.(.NOT.ZXFORC)) THEN IOKX=-1 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 MLREEX=KEVOLL.IPROGX NG =MLREEX.PROG(/1) PGX1 =MLREEX.PROG(1) WHEN, LISTENTI MLENTX=KEVOLL.IPROGX NG =MLENTX.LECT(/1) PGX1 =FLOAT(MLENTX.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 MLREEY=KEVOLL.IPROGY PGY1 =MLREEY.PROG(1) WHEN, LISTENTI MLENTY=KEVOLL.IPROGY PGY1 =FLOAT(MLENTY.LECT(1)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE DO 36 IG=2,NG IOKMI=0 IOKMA=0 CASE, IPLACX WHEN, LISTREEL PGX=MLREEX.PROG(IG) WHEN, LISTENTI PGX=FLOAT(MLENTX.LECT(IG)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL PGY=MLREEY.PROG(IG) WHEN, LISTENTI PGY=FLOAT(MLENTY.LECT(IG)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF ((PGY1-YINF)*(PGY-YINF).LE.0.D0) THEN IF ((PGX-PGX1)*(PGY-PGY1).GT.0.D0) THEN IOKMI=1 VMIN=YINF CALL INTEXT(PGY1,PGY,PGX1,PGX,VMIN) ENDIF IF ((PGX-PGX1)*(PGY-PGY1).LT.0.D0) THEN IOKMA=1 VMAX=YINF CALL INTEXT(PGY1,PGY,PGX1,PGX,VMAX) ENDIF ENDIF IF ((PGY1-YSUP)*(PGY-YSUP).LE.0.D0) THEN IF ((PGX-PGX1)*(PGY-PGY1).GT.0.D0) THEN IOKMA=1 VMAX=YSUP CALL INTEXT(PGY1,PGY,PGX1,PGX,VMAX) ENDIF IF ((PGX-PGX1)*(PGY-PGY1).LT.0.D0) THEN IOKMI=1 VMIN=YSUP CALL INTEXT(PGY1,PGY,PGX1,PGX,VMIN) ENDIF ENDIF IF (.NOT. ((MIN(PGY1,PGY).GT.YSUP).OR. * (MAX(PGY1,PGY).LT.YINF))) THEN IF (IOKMI.EQ.0) VMIN=MIN(PGX1,PGX) IF (IOKMA.EQ.0) VMAX=MAX(PGX1,PGX) IF (IOKX.LE.0) THEN IOKX=1 XINF=VMIN XSUP=VMAX ELSE XINF=MIN(XINF,VMIN) XSUP=MAX(XSUP,VMAX) ENDIF ENDIF PGX1=PGX PGY1=PGY 36 CONTINUE IF (IOKX.LE.0) THEN IPTR=MLREEX CTYP=KEVOLL.TYPX CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN IF (IOKX.EQ.-1) THEN XINF=AMINI XSUP=AMAXI IOKX=0 ELSE XINF=MIN(XINF,AMINI) XSUP=MAX(XSUP,AMAXI) ENDIF ENDIF ENDIF * ******* BORNES IMPOSEES SUR X MAIS PAS SUR Y * IF (ZXFORC.AND.(.NOT.ZYFORC)) THEN IOKY=-1 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 MLREEX=KEVOLL.IPROGX NG =MLREEX.PROG(/1) PGX1 =MLREEX.PROG(1) WHEN, LISTENTI MLENTX=KEVOLL.IPROGX NG =MLENTX.LECT(/1) PGX1 =FLOAT(MLENTX.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 MLREEY=KEVOLL.IPROGY PGY1 =MLREEY.PROG(1) WHEN, LISTENTI MLENTY=KEVOLL.IPROGY PGY1 =FLOAT(MLENTY.LECT(1)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE DO 37 IG=2,NG IOKMI=0 IOKMA=0 CASE, IPLACX WHEN, LISTREEL PGX=MLREEX.PROG(IG) WHEN, LISTENTI PGX=FLOAT(MLENTX.LECT(IG)) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CASE, IPLACY WHEN, LISTREEL PGY=MLREEY.PROG(IG) WHEN, LISTENTI PGY=FLOAT(MLENTY.LECT(IG)) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE IF ((PGX1-XINF)*(PGX-XINF).LE.0.D0) THEN IF ((PGX-PGX1)*(PGY-PGY1).GT.0.D0) THEN IOKMI=1 VMIN=XINF CALL INTEXT(PGX1,PGX,PGY1,PGY,VMIN) ENDIF IF ((PGX-PGX1)*(PGY-PGY1).LT.0.D0) THEN IOKMA=1 VMAX=XINF CALL INTEXT(PGX1,PGX,PGY1,PGY,VMAX) ENDIF ENDIF IF ((PGX1-XSUP)*(PGX-XSUP).LE.0.D0) THEN IF ((PGX-PGX1)*(PGY-PGY1).GT.0.D0) THEN IOKMA=1 VMAX=XSUP CALL INTEXT(PGX1,PGX,PGY1,PGY,VMAX) ENDIF IF ((PGX-PGX1)*(PGY-PGY1).LT.0.D0) THEN IOKMI=1 VMIN=XSUP CALL INTEXT(PGX1,PGX,PGY1,PGY,VMIN) ENDIF ENDIF IF (.NOT. ((MIN(PGX1,PGX).GT.XSUP).OR. * (MAX(PGX1,PGX).LT.XINF))) THEN IF (IOKMI.EQ.0) VMIN=MIN(PGY1,PGY) IF (IOKMA.EQ.0) VMAX=MAX(PGY1,PGY) IF (IOKY.LE.0) THEN IOKY=1 YINF=VMIN YSUP=VMAX ELSE YINF=MIN(YINF,VMIN) YSUP=MAX(YSUP,VMAX) ENDIF ENDIF PGX1=PGX PGY1=PGY 37 CONTINUE IF (IOKY.LE.0) THEN IPTR=MLREEY CTYP=KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN IF (IOKY.EQ.-1) THEN YINF=AMINI YSUP=AMAXI IOKY=0 ELSE YINF=MIN(YINF,AMINI) YSUP=MAX(YSUP,AMAXI) ENDIF ENDIF ENDIF * ******* PAS DE BORNES IMPOSEES * IF ((.NOT.ZXFORC).AND.(.NOT.ZYFORC)) THEN IPTR=KEVOLL.IPROGX CTYP=KEVOLL.TYPX CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN XINF=AMINI XSUP=AMAXI IPTR=KEVOLL.IPROGY CTYP=KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,AMINI,AMAXI,IRET) IF(IERR .NE. 0)RETURN YINF=AMINI YSUP=AMAXI ENDIF ************************************************************************ * CALCUL DES MINI MAXI (TRACES SEPARES) ************************************************************************ IF (ZMIMA) THEN * SAUVEGARDE VALEUR AXE POUR CHERCHER MAXI IPTR=KEVOLL.IPROGY CTYP=KEVOLL.TYPY CALL MINMAX(IPTR,CTYP,YMINI,YMAXI,IRET) IF(IERR .NE. 0)RETURN ENDIF ************************************************************************ * PETITS TRAVAUX SUR LES AXES X et Y (TRACES SEPARES) ************************************************************************ * * DANS LE CAS D'AXES EN LOG, * ON VERIFIE QUE LES BORNES NE SONT PAS NEGATIVES * IF (ZLOGX.AND.XINF.LT.XPETIT) GOTO 900 IF (ZLOGY.AND.YINF.LT.XPETIT) GOTO 900 * * CALCUL DES ARRONDIS * Les bornes passent eventuellement en log10 * CALL BORAXE(XINF,XSUP,ZLOGX) CALL BORAXE(YINF,YSUP,ZLOGY) * * CALCUL DU PAS DE GRADUATION * CALL INTAXE(XINF,XSUP,XINT,INX,ZLOGX,ZARR.OR.ZXFORC) CALL INTAXE(YINF,YSUP,YINT,INY,ZLOGY,ZARR.OR.ZYFORC) * ENDIF *==== FIN DU CAS D'UN TRACE SEPARE (COURBE PAR COURBE) ================= *======================================================================= ************************************************************************ * SAUVEGARDE DE L'AXE POUR RETOUR GRAPHE INITIAL ************************************************************************ * SEGINI,OLDAXE=AXE ************************************************************************ * TRAITEMENT TRACE ************************************************************************ * * INITIALISATION DU GRAPHIQUE ****************************************** * 38 CONTINUE CALL OPTDES(IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,TTXX,TTXXX, & TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,DYN,NDIMT,CUR,NDIMT2,NC & ,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,IPOSI,XPOSI,YPOSI,IGRIL) IF (IERR.NE.0) GOTO 1000 IF (PASSE.LT.0.5) THEN TDX = ((TTXXX-TTXX)/10.)*3./4. TDY = ((TTYYY-TTYY)/10.)*15./14. TCENTX = TTXXX-(TDX/2.) TCENTY = TTYYY-(TDY/2.) OLDLOGX= TCENTX OLDLOGY= TCENTY OLDTX1 = TTXX OLDTY1 = TTYY OLDTX2 = TTXXX OLDTY2 = TTYYY PASSE = 1. ENDIF * * MEMORISATION POUR IMPRESSION DU DESSIN * * CALL MAJSEG(1,0,0,0,0) *********************************************** * APPEL DE NLOGO IF (ZLOGO) THEN CALL LOGDES(TTXXX,TTYYY,TTXX,TTYY,AXE, & tcentx,tcenty,htlog,icolog) CALL CHCOUL(IDCOUL) ENDIF * * COMMENTAIRES SI IL Y EN A * SEGACT COM IF (ICOM.NE.0) THEN DO JK=1,ICOM CALL CHCOUL(ICOUCO(JK)) CALL TRLABL(TXCOM(JK),TYCOM(JK),0.,COMMENT(JK),30,HMIN) ENDDO CALL CHCOUL(IDCOUL) ENDIF * BERTIN: Redessiner le lien IF(ZLIEN) THEN DO JK=1, ICOM TX(1)=LIEN(JK,1) TY(1)=LIEN(JK,2) TX(2)=LIEN(JK,3) TY(2)=LIEN(JK,4) CALL POLRL(2,TX,TY,tz) ENDDO ENDIF * * INDEX * IF (ZINDEX) THEN CALL CHCOUL(INDCOU) C (fdp) Affichage de la ligne horizontale de la croix TX(1)=XINF TX(2)=XSUP IF (ZLOGY) THEN TY(1)=LOG10(TLACY) ELSE TY(1)=TLACY ENDIF TY(2)=TY(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage de la ligne verticale de la croix TY(1)=YINF TY(2)=YSUP IF (ZLOGX) THEN TX(1)=LOG10(TLACX) ELSE TX(1)=TLACX ENDIF TX(2)=TX(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage des valeurs X et Y pointees IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF TXINF=XINF TYINF=YINF CALL TRLABL(TXINF,TLACY0+0.02,0.,CARDY,11,HMIN) CALL TRLABL(TLACX0,TYINF+0.02,0.,CARDX,11,HMIN) ENDIF CALL TRCLIK(KCLICK) * * MEMORISATION POUR IMPRESSION DU DESSIN * * CALL MAJSEG(1,0,0,0,0) * * EN INTERACTIF CREATION MENU PRINCIPAL * EN BATCH LOCAL CREATION FICHIER PUN * EN BATCH AUCUN EFFET * 50 CONTINUE LEGEND(1)=' Fin dessin' LEGEND(2)=' Zoom ' LEGEND(3)=' Initial ' LEGEND(4)=' Valeur ' LEGEND(5)=' Presenter ' LEGEND(6)=' Options ' CALL MENU(LEGEND,6,13) * CALL TRAFF(ICLE) IF ((ICLE.GT.5).OR.(ICLE.LT.0)) GOTO 50 * * GESTION DU ZOOM * IF (ICLE.EQ.1) THEN * 51 CONTINUE BUFFER='Cliquez 2 coins opposes ' CALL TRMESS(BUFFER) * Premier clic CALL TRDIG(TXX1,TYY1,INOUSE) * Deuxieme clic CALL TRDIG(TXX2,TYY2,INOUSE) * * Test position des deux coins l'un par rapport a l'autre * Superieur gauche TXX=MIN(TXX1,TXX2) TYY=MAX(TYY1,TYY2) * Inferieur droit TXXX=MAX(TXX1,TXX2) TYYY=MIN(TYY1,TYY2) *PM IF ((ZLOGX).AND.(TXX .LT.1.E-30)) GOTO 51 ????????????? *PM IF ((ZLOGY).AND.(TYYY.LT.1.E-30)) GOTO 51 ????????????? * * Restriction de la fenetre aux nouvelles bornes * On n'intervient sur les bornes que s'il n'y a pas eu deux clics * en dehors du cadre du meme cote : on ignore alors le zoom * sur la coordonnee hors cadre. XINFN = XINF XSUPN = XSUP YINFN = YINF YSUPN = YSUP IF ((TXX.GT.REAL(XINF)).AND.(TXX.LT.REAL(XSUP))) THEN XINFN=DBLE(TXX) ENDIF IF ((TYY.LT.REAL(YSUP)).AND.(TYY.GT.REAL(YINF))) THEN YSUPN=DBLE(TYY) ENDIF IF ((TXXX.LT.REAL(XSUP)).AND.(TXXX.GT.REAL(XINF))) THEN XSUPN=DBLE(TXXX) ENDIF IF ((TYYY.GT.REAL(YINF)).AND.(TYYY.LT.REAL(YSUP))) THEN YINFN=DBLE(TYYY) ENDIF * XINF, XSUP, YINF, YSUP sont eventuellement log10 * on determine les nouvelles valeurs non transformees. IF (ZLOGX) THEN XINF = 10.D0**XINFN XSUP = 10.D0**XSUPN ELSE XINF = XINFN XSUP = XSUPN ENDIF IF (ZLOGY) THEN YINF = 10.D0**YINFN YSUP = 10.D0**YSUPN ELSE YINF = YINFN YSUP = YSUPN ENDIF * * CALCUL POUR LE NOUVEL AXE * Les bornes repassent eventuellement en log10 * CALL BORAXE(XINF,XSUP,ZLOGX) CALL BORAXE(YINF,YSUP,ZLOGY) CALL INTAXE(XINF,XSUP,XINT,INX,ZLOGX,ZARR.OR.ZXFORC) CALL INTAXE(YINF,YSUP,YINT,INY,ZLOGY,ZARR.OR.ZYFORC) * * Calcul nouvelles coordonnees logo * DELTX1 = OLDAXE.XSUP - OLDAXE.XINF DELTX2 = XSUP - XINF DELTY1 = OLDAXE.YSUP - OLDAXE.YINF DELTY2 = YSUP - YINF DELTX = DELTX1 / DELTX2 DELTY = DELTY1 / DELTY2 TCENTX = ((OLDLOGX - OLDAXE.XINF) / DELTX) + XINF TCENTY = ((OLDLOGY - OLDAXE.YINF) / DELTY) + YINF GOTO 38 ENDIF * * GESTION RETOUR AU GRAPHE ORIGINAL * IF (ICLE.NE.2) GOTO 7654 CONTINUE tcexx= (TCENTX -XSUP )/ ( XSUP-XINF) tceyy= (TCENTY -YSUP )/ ( YSUP-YINF) XINF = OLDAXE.XINF XSUP = OLDAXE.XSUP YSUP = OLDAXE.YSUP YINF = OLDAXE.YINF XINT = OLDAXE.XINT YINT = OLDAXE.YINT INX = OLDAXE.INX INY = OLDAXE.INY TTXX = OLDTX1 TTYY = OLDTY1 TTXXX = OLDTX2 TTYYY = OLDTY2 TDX = ((TTXXX-TTXX)/10.)* 3./4. TDY = ((TTYYY-TTYY)/10.)*15./14. TCENTX=tcexx *(XSUP-XINF) +XSUP TCENTY=tceyy *(ySUP-yINF) +ySUP * TCENTX = TTXXX-(TDX/2.) * TCENTY = TTYYY-(TDY/2.) OLDLOGX= TCENTX OLDLOGY= TCENTY GOTO 38 7654 CONTINUE * * GESTION AFFICHAGE DE VALEUR * IF (ICLE.NE.3) GOTO 7657 ZVALEUR=.TRUE. ICOURB=1 TXXX=REAL(XINF+(XSUP-XINF)/2.D0) TYYY=REAL(YINF+(YSUP-YINF)/2.D0) C Acquisition des coordonnees X Y du pointeur de la souris dans la C fenetre par click de l'utilisateur 52 CONTINUE CALL TRDIG(TXXX,TYYY,INOUSE) TXXA=TXXX TYYA=TYYY C Recheche du numero JKNUM du point de l'evolution ICOURB le plus C proche du point clicke MEVOLL=IEV KEVOLL=IEVOLL(ICOURB) 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 MLREEX=KEVOLL.IPROGX MLENTX=0 JG =MLREEX.PROG(/1) WHEN, LISTENTI MLREEX=0 MLENTX=KEVOLL.IPROGX JG =MLENTX.LECT(/1) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE CALL CHCOUL(IDCOUL) 77 CONTINUE C Numero de couleur de l'evolution ICOURB INDCOU=NUMEVX JKNUM =1 CASE, IPLACX WHEN, LISTREEL XVAL1=MLREEX.PROG(JG) WHEN, LISTENTI XVAL1=FLOAT(MLENTX.LECT(JG)) WHENOTHERS ENDCASE C write(6,*)'dessin: XVAL1,TXXA',XVAL1,TXXA IF(XVAL1.LE.TXXA) THEN C JKNUM=XVAL1 GOTO 777 ENDIF DO JK=1,JG CASE, IPLACX WHEN, LISTREEL XVALi=MLREEX.PROG(JK) WHEN, LISTENTI XVALi=FLOAT(MLENTX.LECT(JK)) WHENOTHERS ENDCASE IF(XVALi.GT.TXXA) THEN IF(JK.GT.1) THEN CASE, IPLACX WHEN, LISTREEL XVALi1=MLREEX.PROG(JK-1) WHEN, LISTENTI XVALi1=FLOAT(MLENTX.LECT(JK-1)) WHENOTHERS ENDCASE IF(ABS(XVALi-TXXA) .GT. ABS(XVALi1-TXXA)) THEN JKNUM=JK-1 ELSE JKNUM=JK ENDIF ELSE JKNUM=JK ENDIF GOTO 777 ENDIF ENDDO 777 CONTINUE BUFFER4=' Courbe : ' BUFFER3='Point : ' C Recuperation des abscisses et ordonnees du curseur, il s'agit du C point numero JKNUM de l'evolution ICOURB CASE, IPLACX WHEN, LISTREEL ITOTO=1 TXXA =MLREEX.PROG(JKNUM) WHEN, LISTENTI TXXA =FLOAT(MLENTX.LECT(JKNUM)) WHENOTHERS ENDCASE BUFFER1='X : ' 7773 WRITE(BUFFER4(12:18),FMT='(I6)' ) ICOURB WRITE(BUFFER3(9:15) ,FMT='(I6)' ) JKNUM WRITE(BUFFER1(4:14) ,FMT='(G11.4)') TXXA BUFFER2='Y : ' 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 MLREEY=KEVOLL.IPROGY MLENTY=0 TYYA =MLREEY.PROG(JKNUM) WHEN, LISTENTI MLREEY=0 MLENTY=KEVOLL.IPROGY TYYA =MLENTY.LECT(JKNUM) WHENOTHERS MOTERR =CTYP CALL ERREUR(39) RETURN ENDCASE WRITE (BUFFER2(4:14),FMT='(G11.4)') TYYA C Pour l'affichage d'une croix au point correspondant au curseur C et avec la couleur de la courbe choisie s'il vous plait ! ZINDEX=.TRUE. TLACX =TXXA TLACY =TYYA IF (ZVALEUR) THEN C test sur les bornes de la fenetre de trace C attention, en ca sd'echelle logarithmique, il ne faut pas C raisonner sur la valeur X mais sur la valeur p telle que X=10^p IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF IF (TLACY0.GT.REAL(YSUP)) THEN TLACY0=REAL(YSUP) ENDIF IF (TLACY0.LT.REAL(YINF)) THEN TLACY0=REAL(YINF) ENDIF IF (TLACX0.GT.REAL(XSUP)) THEN TLACX0=REAL(XSUP) ENDIF IF (TLACX0.LT.REAL(XINF)) THEN TLACX0=REAL(XINF) ENDIF WRITE (CARDX(1:11),FMT='(G11.4)') TLACX WRITE (CARDY(1:11),FMT='(G11.4)') TLACY GOTO 5000 ENDIF 7772 CONTINUE C Affichage du texte en bas de la fenetre et du menu de deplacement C du curseur ZVALEUR=.TRUE. CALL TRMESS(BUFFER1//BUFFER2//BUFFER3//BUFFER4) LEGEND(1)=' Retour ' LEGEND(2)=' <-- ' LEGEND(3)=' --> ' LEGEND(4)=' Courbe prec.' LEGEND(5)=' Courbe suiv.' CALL MENU(LEGEND,5,13) CALL TRAFF(ICLE9) C Gestion du deplacement du curseur C - cas du click sur la case "Retour" IF (ICLE9.EQ.0) THEN ZVALEUR=.FALSE. GOTO 50 C - cas du click sur la case "<--" (point precedant) ELSEIF (ICLE9.EQ.1) THEN JKNUM=JKNUM-1 IF(JKNUM .EQ. 0) JKNUM = JG CASE, IPLACX WHEN, LISTREEL ITOTO=2 TXXA=MLREEX.PROG(JKNUM) WHEN, LISTENTI TXXA=FLOAT(MLENTX.LECT(JKNUM)) WHENOTHERS ENDCASE GOTO 7773 C - cas du click sur la case "-->" (point suivant) ELSEIF (ICLE9.EQ.2) THEN JKNUM=JKNUM+1 IF(JKNUM .EQ. JG+1) JKNUM = 1 CASE, IPLACX WHEN, LISTREEL TXXA=MLREEX.PROG(JKNUM) WHEN, LISTENTI TXXA=FLOAT(MLENTX.LECT(JKNUM)) WHENOTHERS ENDCASE GOTO 7773 C - cas du click sur la case "Courbe precedente" ELSEIF (ICLE9.EQ.3) THEN 77721 CONTINUE ICOURB=ICOURB-1 IF (ICOURB.EQ.0) ICOURB=INBEVO KEVOLL=IEVOLL(ICOURB) 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 MLREEX=KEVOLL.IPROGX MLENTX=0 JG =MLREEX.PROG(/1) WHEN, LISTENTI MLREEX=0 MLENTX=KEVOLL.IPROGX JG =MLENTX.LECT(/1) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE IF (JG.EQ.0) GOTO 77721 GOTO 77 C - cas du click sur la case "Courbe suivante" ELSEIF (ICLE9.EQ.4) THEN 77722 CONTINUE ICOURB=ICOURB+1 IF (ICOURB.EQ.INBEVO+1) ICOURB=1 KEVOLL=IEVOLL(ICOURB) 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 MLREEX=KEVOLL.IPROGX MLENTX=0 JG =MLREEX.PROG(/1) WHEN, LISTENTI MLREEX=0 MLENTX=KEVOLL.IPROGX JG =MLENTX.LECT(/1) WHENOTHERS MOTERR=CTYP CALL ERREUR(39) RETURN ENDCASE IF (JG.EQ.0) GOTO 77722 GOTO 77 C - dans les autres cas, on repart a l'acquisition des coordonnees C du pointeur de souris ELSE GOTO 52 ENDIF 7657 CONTINUE * * IMPRESSION PAR CREATION D'UN FICHIER LGI * IF (ICLE .EQ. 11) THEN CALL FLGI GOTO 50 ENDIF * * GESTION DES OPTIONS * IF (ICLE.EQ.5) THEN LEGEND(1)=' Retour ' LEGEND(2)=' Fonts>> ' IF (ICOSC.EQ.1) THEN LEGEND(3)='Ecran>> Blanc' ELSE IF (ICOSC.EQ.2) THEN LEGEND(3)='Ecran>> Noir' ENDIF IF (ZDATE) THEN LEGEND(4)=' (X) Date ' ELSE LEGEND(4)=' ( ) Date ' ENDIF IF (ZGRILL) THEN LEGEND(5)=' (X)Grille ' ELSE LEGEND(5)=' ( )Grille ' ENDIF CALL MENU(LEGEND,5,13) CALL TRAFF (ICLE2) IF (ICLE2.EQ.0) GOTO 38 IF (ICLE2.EQ.1) THEN LEGEND(1)=' Retour ' LEGEND(2)=' 8_BY_13 ' LEGEND(3)=' 9_BY_15 ' LEGEND(4)=' TIMES_10 ' LEGEND(5)=' TIMES_24 ' LEGEND(6)=' HELV_10 ' LEGEND(7)=' HELV_12 ' LEGEND(8)=' HELV_18 ' CALL MENU(LEGEND,8,13) CALL TRAFF(ICLE3) IF (ICLE3.EQ.0) GOTO 38 IOPOLI=ICLE3 GOTO 38 ELSEIF (ICLE2.EQ.2) THEN IF (ICOSC.EQ.1) THEN ICOSC=2 ELSE IF (ICOSC.EQ.2) THEN ICOSC=1 ENDIF GOTO 38 ELSEIF (ICLE2.EQ.3) THEN IF (ZDATE) THEN ZDATE=.FALSE. ELSE ZDATE=.TRUE. ENDIF GOTO 38 ELSEIF (ICLE2.EQ.4) THEN IF (ZGRILL) THEN ZGRILL=.FALSE. ELSE ZGRILL=.TRUE. IGRIL = 1 ENDIF GOTO 38 ENDIF ENDIF * * GESTION PRESENTATION * **TC IF (ICLE.EQ.4) THEN IF( ICLE.ne.4) go to 7659 * TRACE GRAPHIQUE ****************************************************** 5000 CONTINUE CALL OPTDES(IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,TTXX,TTXXX, & TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,DYN,NDIMT,CUR,NDIMT2,NC & ,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,IPOSI,XPOSI,YPOSI,IGRIL) IF (IERR.NE.0) GOTO 1000 * APPEL DE NLOGO IF (ZLOGO) THEN CALL LOGDES(TTXXX,TTYYY,TTXX,TTYY,AXE, & TCENTX,TCENTY,HTLOG,ICOLOG) CALL CHCOUL(IDCOUL) ENDIF * * COMMENTAIRES SI IL Y EN A * SEGACT COM IF (ICOM.NE.0) THEN DO JK=1,ICOM CALL CHCOUL(ICOUCO(JK)) CALL TRLABL(TXCOM(JK),TYCOM(JK),0.,COMMENT(JK),30,HMIN) ENDDO CALL CHCOUL(IDCOUL) ENDIF * BERTIN: Redessiner le lien IF(ZLIEN) THEN DO JK=1, ICOM TX(1)=LIEN(JK,1) TY(1)=LIEN(JK,2) TX(2)=LIEN(JK,3) TY(2)=LIEN(JK,4) CALL POLRL(2,TX,TY,tz) ENDDO ENDIF * * INDEX * IF (ZINDEX) THEN CALL CHCOUL(INDCOU) C (fdp) Affichage de la ligne horizontale de la croix TX(1)=XINF TX(2)=XSUP IF (ZLOGY) THEN TY(1)=LOG10(TLACY) ELSE TY(1)=TLACY ENDIF TY(2)=TY(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage de la ligne verticale de la croix TY(1)=YINF TY(2)=YSUP IF (ZLOGX) THEN TX(1)=LOG10(TLACX) ELSE TX(1)=TLACX ENDIF TX(2)=TX(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage des valeurs X et Y pointees IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF TXINF=XINF TYINF=YINF CALL TRLABL(TXINF,TLACY0+0.02,0.,CARDY,11,HMIN) CALL TRLABL(TLACX0,TYINF+0.02,0.,CARDX,11,HMIN) ENDIF ************************************************************************ IF (ZVALEUR) THEN ZVALEUR=.FALSE. GOTO 7772 END IF LEGEND(1)='Retour' LEGEND(2)='Index' LEGEND(3)='Enleve index' LEGEND(4)='Comment>> ' LEGEND(5)='Logo>> ' LEGEND(6)='Titres>> ' CALL MENU(LEGEND,6,13) CALL TRAFF(ICLE3) C - cas du click sur la case "Retour" IF (ICLE3.EQ.0) THEN GOTO 38 C - cas du click sur la case "Index" ELSEIF (ICLE3.EQ.1) THEN ZINDEX=.TRUE. C acquisition des coordonnees X Y du pointeur de la souris dans C la fenetre par click de l'utilisateur BUFFER='Pointez index' CALL TRMESS(BUFFER) CALL TRDIG (TLACX,TLACY,INOUSE) INDCOU=IDCOUL C test sur les bornes de la fenetre de trace IF (TLACY.GT.REAL(YSUP)) THEN TLACY=REAL(YSUP) ENDIF IF (TLACY.LT.REAL(YINF)) THEN TLACY=REAL(YINF) ENDIF IF (TLACX.GT.REAL(XSUP)) THEN TLACX=REAL(XSUP) ENDIF IF (TLACX.LT.REAL(XINF)) THEN TLACX=REAL(XINF) ENDIF C convertion si echelles logarithmiques IF (ZLOGX) TLACX=10D0**TLACX IF (ZLOGY) TLACY=10D0**TLACY WRITE (CARDX(1:11),FMT='(G11.4)') TLACX WRITE (CARDY(1:11),FMT='(G11.4)') TLACY GOTO 5000 C - cas du click sur la case "Enleve index" ELSEIF (ICLE3.EQ.2) THEN ZINDEX=.FALSE. GOTO 5000 C - cas du click sur la case "Comment>>" ELSEIF (ICLE3.EQ.3) THEN GOTO 6800 C - cas du click sur la case "Logo>>" ELSEIF (ICLE3.EQ.4) THEN GOTO 6000 C - cas du click sur la case "Titres>>" ELSEIF (ICLE3.EQ.5) THEN GOTO 6500 ENDIF * TRACE GRAPHIQUE ****************************************************** 6000 CONTINUE CALL OPTDES(IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,TTXX,TTXXX, & TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,DYN,NDIMT,CUR,NDIMT2,NC & ,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,IPOSI,XPOSI,YPOSI,IGRIL) IF (IERR.NE.0) GOTO 1000 * APPEL DE NLOGO IF (ZLOGO) THEN CALL LOGDES(TTXXX,TTYYY,TTXX,TTYY,AXE, & TCENTX,TCENTY,HTLOG,ICOLOG) CALL CHCOUL(IDCOUL) ENDIF * * COMMENTAIRES SI IL Y EN A * SEGACT COM IF (ICOM.NE.0) THEN DO JK=1,ICOM CALL CHCOUL(ICOUCO(JK)) CALL TRLABL(TXCOM(JK),TYCOM(JK),0.,COMMENT(JK),30,HMIN) ENDDO CALL CHCOUL(IDCOUL) ENDIF * BERTIN: Redessiner le lien IF(ZLIEN) THEN DO JK=1, ICOM TX(1)=LIEN(JK,1) TY(1)=LIEN(JK,2) TX(2)=LIEN(JK,3) TY(2)=LIEN(JK,4) CALL POLRL(2,TX,TY,tz) ENDDO ENDIF * * INDEX * IF (ZINDEX) THEN CALL CHCOUL(INDCOU) C (fdp) Affichage de la ligne horizontale de la croix TX(1)=XINF TX(2)=XSUP IF (ZLOGY) THEN TY(1)=LOG10(TLACY) ELSE TY(1)=TLACY ENDIF TY(2)=TY(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage de la ligne verticale de la croix TY(1)=YINF TY(2)=YSUP IF (ZLOGX) THEN TX(1)=LOG10(TLACX) ELSE TX(1)=TLACX ENDIF TX(2)=TX(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage des valeurs X et Y pointees IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF TXINF=XINF TYINF=YINF CALL TRLABL(TXINF,TLACY0+0.02,0.,CARDY,11,HMIN) CALL TRLABL(TLACX0,TYINF+0.02,0.,CARDX,11,HMIN) ENDIF LEGEND(1)=' << Logo' LEGEND(2)='Position' LEGEND(3)='Couleur' LEGEND(4)='Taille' IF (ZLOGO) THEN LEGEND(5)=' (X) Logo' ELSE LEGEND(5)=' ( ) Logo' ENDIF CALL MENU(LEGEND,5,13) CALL TRAFF(ICLE4) * REVENIR IF (ICLE4.EQ.0) GOTO 5000 * POSITION IF (ICLE4.EQ.1) THEN CALL TRMESS('Cliquer sur la nouvelle position') CALL TRDIG(TCENTX,TCENTY,inouse) OLDLOGX=TCENTX OLDLOGY=TCENTY ENDIF * COULEUR IF (ICLE4.EQ.2) THEN NUM=NBCOUL CALL TRGETC(NUM) ICOLOG = NUM ENDIF * TAILLE IF (ICLE4.EQ.3) THEN CALL TRGET('Entrer la nouvelle taille du logo 1 a 9:',TMPCAR) READ(TMPCAR,'(I2)') IRA IF (IRA.LE.0 ) IRA=1 IF (IRA.GE.10) IRA=9 HTLOG = REAL (IRA) * HDPLOG ENDIF * ON/OFF IF (ICLE4.EQ.4) THEN IF (ZLOGO) THEN ZLOGO = .FALSE. ELSE ZLOGO = .TRUE. ENDIF ENDIF * RETOUR GOTO 6000 * ENDIF * TRACE GRAPHIQUE ****************************************************** 6500 CONTINUE CALL OPTDES (IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,TTXX,TTXXX, & TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,DYN,NDIMT,CUR,NDIMT2,NC & ,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,IPOSI,XPOSI,YPOSI,IGRIL) IF (IERR.NE.0) GOTO 1000 * APPEL DE NLOGO IF (ZLOGO) THEN CALL LOGDES(TTXXX,TTYYY,TTXX,TTYY,AXE, & TCENTX,TCENTY,HTLOG,ICOLOG) CALL CHCOUL(IDCOUL) ENDIF * COMMENTAIRES SI IL Y EN A IF (ICOM.NE.0) THEN DO JK=1,ICOM CALL CHCOUL(ICOUCO(JK)) CALL TRLABL(TXCOM(JK),TYCOM(JK),0.,COMMENT(JK),30,HMIN) ENDDO CALL CHCOUL(IDCOUL) ENDIF * BERTIN: Redessiner le lien IF(ZLIEN) THEN DO JK=1, ICOM TX(1)=LIEN(JK,1) TY(1)=LIEN(JK,2) TX(2)=LIEN(JK,3) TY(2)=LIEN(JK,4) CALL POLRL(2,TX,TY,tz) ENDDO ENDIF * INDEX IF (ZINDEX) THEN CALL CHCOUL(INDCOU) C (fdp) Affichage de la ligne horizontale de la croix TX(1)=XINF TX(2)=XSUP IF (ZLOGY) THEN TY(1)=LOG10(TLACY) ELSE TY(1)=TLACY ENDIF TY(2)=TY(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage de la ligne verticale de la croix TY(1)=YINF TY(2)=YSUP IF (ZLOGX) THEN TX(1)=LOG10(TLACX) ELSE TX(1)=TLACX ENDIF TX(2)=TX(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage des valeurs X et Y pointees IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF TXINF=XINF TYINF=YINF CALL TRLABL(TXINF,TLACY0+0.02,0.,CARDY,11,HMIN) CALL TRLABL(TLACX0,TYINF+0.02,0.,CARDX,11,HMIN) ENDIF LEGEND (1)=' << Titres' LEGEND (2)='Titre gene.' LEGEND (3)='Titre X' LEGEND (4)='Titre Y' CALL MENU(LEGEND,4,13) CALL TRAFF(ICLE5) * REVENIR IF (ICLE5.EQ.0) GOTO 5000 * TITRE GENERAL IF (ICLE5.EQ.1) THEN CALL TRGET ('Entrez le nouveau titre general :',TMPCAR) TXTIT=TMPCAR ENDIF * TITRE EN X IF (ICLE5.EQ.2) THEN CALL TRGET ('Entrez le nouveau titre en X :',TMPCAR) TXAXE=TMPCAR ENDIF * TITRE EN Y IF (ICLE5.EQ.3) THEN CALL TRGET ('Entrez le nouveau titre en Y :',TMPCAR) TYAXE=TMPCAR ENDIF * RETOUR GOTO 6500 * ENDIF * TRACE GRAPHIQUE ****************************************************** 6800 CONTINUE CALL OPTDES (IOPTIO,NOL,AXE,TITRE,TXTIT,TXAXE,TYAXE,TTXX,TTXXX, & TTYY,TTYYY,ZAXES,ZSEPAR,ZOPTIO,ZLEGEN,IEV,DYN,NDIMT,CUR,NDIMT2,NC & ,INBEVO,ZMIMA,ZDATE,YMINI,YMAXI,IPOSI,XPOSI,YPOSI,IGRIL) IF (IERR.NE.0) GOTO 1000 * APPEL DE NLOGO IF (ZLOGO) THEN CALL LOGDES(TTXXX,TTYYY,TTXX,TTYY,AXE, & TCENTX,TCENTY,HTLOG,ICOLOG) CALL CHCOUL(IDCOUL) ENDIF * COMMENTAIRES SI IL Y EN A IF (ICOM.NE.0) THEN DO JK=1,ICOM CALL CHCOUL(ICOUCO(JK)) CALL TRLABL (TXCOM(JK),TYCOM(JK),0.,COMMENT(JK),30,HMIN) ENDDO CALL CHCOUL(IDCOUL) ENDIF * INDEX IF (ZINDEX) THEN CALL CHCOUL(INDCOU) C (fdp) Affichage de la ligne horizontale de la croix TX(1)=XINF TX(2)=XSUP IF (ZLOGY) THEN TY(1)=LOG10(TLACY) ELSE TY(1)=TLACY ENDIF TY(2)=TY(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage de la ligne verticale de la croix TY(1)=YINF TY(2)=YSUP IF (ZLOGX) THEN TX(1)=LOG10(TLACX) ELSE TX(1)=TLACX ENDIF TX(2)=TX(1) CALL POLRL(2,TX,TY,tz) C (fdp) Affichage des valeurs X et Y pointees IF (ZLOGX) THEN TLACX0=LOG10(TLACX) ELSE TLACX0=TLACX ENDIF IF (ZLOGY) THEN TLACY0=LOG10(TLACY) ELSE TLACY0=TLACY ENDIF TXINF=XINF TYINF=YINF CALL TRLABL(TXINF ,TLACY0+0.02,0.,CARDY,11,HMIN) CALL TRLABL(TLACX0,TYINF +0.02,0.,CARDX,11,HMIN) ENDIF * BERTIN: Redessiner le lien IF(ZLIEN) THEN DO JK=1, ICOM TX(1)=LIEN(JK,1) TY(1)=LIEN(JK,2) TX(2)=LIEN(JK,3) TY(2)=LIEN(JK,4) CALL POLRL(2,TX,TY,tz) ENDDO ENDIF LEGEND (1)='Comment <<' LEGEND (2)='Ajout' LEGEND (3)='Enleve/Modif' LEGEND (4)='Deplacement' LEGEND (5)='Couleur' LEGEND (6)='Lien' CALL MENU(LEGEND,6,13) CALL TRAFF(ICLE6) * REVENIR IF (ICLE6.EQ.0) GOTO 5000 * AJOUT IF (ICLE6.EQ.1) THEN IF (ICOM.EQ.10) THEN BUFFER='10 commentaires maxi - Pointer' CALL TRMESS(BUFFER) CALL TRDIG(TXXX,TYYY,INOUSE) GOTO 6800 ELSE ICOM=ICOM+1 TXXX=REAL(XINF+(XSUP-XINF)/2.D0) TYYY=REAL(YINF+(YSUP-YINF)/2.D0) BUFFER='Pointez commentaire' CALL TRMESS(BUFFER) CALL TRDIG(TXXX,TYYY,INOUSE) CALL TRGET('Entrez le commentaire :',TMPCAR) COMMENT(ICOM)=TMPCAR TXCOM(ICOM) =TXXX TYCOM(ICOM) =TYYY ICOUCO(ICOM) =IDCOUL GOTO 6800 ENDIF ENDIF * SUPRESSION IF (ICLE6.EQ.2) THEN IF (ICOM.NE.0) THEN BUFFER='Pointez commentaire' CALL TRMESS(BUFFER) CALL TRDIG(TXXX,TYYY,INOUSE) CALL CHERCO(TXXX,TYYY,ICOM,AXE,IBON,COM) IF (IBON.NE.0) THEN TMPCAR=' ' CALL TRGET ('Entrez le commentaire :',TMPCAR) IF (TMPCAR.NE.' ') THEN COMMENT(IBON)=TMPCAR ELSE IF (IBON.EQ.ICOM) THEN ICOM=ICOM - 1 TXCOM(IBON)=0. TYCOM(IBON)=0. ICOUCO(IBON)=0 LIEN(IBON,1)=0. LIEN(IBON,2)=0. LIEN(IBON,3)=0. LIEN(IBON,4)=0. ELSE DO J=IBON+1,ICOM TXCOM(J-1)=TXCOM(J) TYCOM(J-1)=TYCOM(J) COMMENT(J-1)=COMMENT(J) ICOUCO(J-1)=ICOUCO(J) LIEN(J-1,1)=LIEN(J,1) LIEN(J-1,2)=LIEN(J,2) LIEN(J-1,3)=LIEN(J,3) LIEN(J-1,4)=LIEN(J,4) ENDDO TXCOM(ICOM)=0. TYCOM(ICOM)=0. ICOUCO(ICOM)=0 COMMENT(ICOM)=' ' ICOM=ICOM - 1 * LIEN(ICOM,1)=0. * LIEN(ICOM,2)=0. * LIEN(ICOM,3)=0. * LIEN(ICOM,4)=0. ENDIF GOTO 6800 ENDIF ELSE GOTO 6800 ENDIF ENDIF GOTO 6800 ENDIF * DEPLACEMENT IF (ICOM.NE.0) THEN IF (ICLE6.EQ.3) THEN BUFFER='Pointez commentaire' CALL TRMESS(BUFFER) CALL TRDIG(TXXX,TYYY,INOUSE) CALL CHERCO(TXXX,TYYY,ICOM,AXE,IBON,COM) IF (IBON.NE.0) THEN BUFFER='Nouvelle position ?' CALL TRMESS(BUFFER) CALL TRDIG(TXXX,TYYY,INOUSE) TXCOM(IBON)=TXXX TYCOM(IBON)=TYYY GOTO 38 ENDIF GOTO 6800 ENDIF ENDIF *COULEUR IF (ICOM.NE.0) THEN IF (ICLE6.EQ.4) THEN BUFFER='Pointez commentaire' CALL TRMESS(BUFFER) CALL TRDIG (TXXX,TYYY,INOUSE) CALL CHERCO(TXXX,TYYY,ICOM,AXE,IBON,COM) IF (IBON.NE.0) THEN NUM=NBCOUL CALL TRGETC(NUM) ICOUCO(IBON) = NUM ENDIF GOTO 6800 ENDIF ENDIF * BERTIN: Creation d'un trait entre un commentaire et une zone * LIEN IF (ICOM.NE.0) THEN IF (ICLE6.EQ.5) THEN ZLIEN=.TRUE. BUFFER='Pointez commentaire' CALL TRMESS(BUFFER) CALL TRDIG (TXXX,TYYY,INOUSE) CALL CHERCO (TXXX,TYYY,ICOM,AXE,IBON,COM) LIEN(IBON,1)=TXCOM(IBON) LIEN(IBON,2)=TYCOM(IBON) IF (IBON.NE.0) THEN BUFFER='Zone a annoter ?' CALL TRMESS(BUFFER) CALL TRDIG (TXXX,TYYY,INOUSE) LIEN(IBON,3)=TXXX LIEN(IBON,4)=TYYY LIEN(IBON,5)=1. TX(1)=LIEN(IBON,1) TY(1)=LIEN(IBON,2) TX(2)=LIEN(IBON,3) TY(2)=LIEN(IBON,4) CALL POLRL(2,TX,TY,tz) ENDIF GOTO 6800 ENDIF ENDIF * BERTIN: Fin creation lien commentaire * RETOUR GOTO 6800 **TC ENDIF 7659 continue * * RETOUR EVOLUTION SUIVANTE EN MODE SEPARE * IF (ZSEPAR) THEN PASSE = 0. HTLOG = 1. ICOLOG = IDCOUL ZLOGO = ZLOGOO IF (ICOM.NE.0) THEN DO JK=1,ICOM TXCOM(JK)=0. TYCOM(JK)=0. COMMENT(JK)=' ' ENDDO ICOM=0 ENDIF ZINDEX= .FALSE. GOTO 34 ENDIF GOTO 1000 * On limite la precision a XPETIT pour les logarithmes 900 REAERR(1)=XPETIT CALL ERREUR(434) GOTO 1000 * L'intervalle entre les bornes est trop faible. 950 CALL ERREUR (497) GOTO 1000 * 1000 CONTINUE * * Nettoyage des courbes avec histogrammes IF (NHIST.NE.0) THEN IF (MEVOLL.NE.0) THEN DO I0=1,IEVOLL(/1) KEVOLL=IEVOLL(I0) IF (NUMEVY.EQ.'HIST') THEN CTYP =KEVOLL.TYPX CALL PLAMO8(CLIST,NLIST,IPLACX,CTYP) IF (IPLACX.EQ.LISTREEL) THEN MLREEX=KEVOLL.IPROGX SEGSUP,MLREEX ELSEIF (IPLACX.EQ.LISTENTI) THEN MLENTX=KEVOLL.IPROGX SEGSUP,MLENTX ENDIF * CTYP =KEVOLL.TYPY CALL PLAMO8(CLIST,NLIST,IPLACY,CTYP) IF (IPLACY.EQ.LISTREEL) THEN MLREEY=KEVOLL.IPROGY SEGSUP,MLREEY ELSEIF (IPLACY.EQ.LISTENTI) THEN MLENTY=KEVOLL.IPROGY SEGSUP,MLENTY ENDIF ENDIF SEGSUP KEVOLL ENDDO SEGSUP,MEVOLL ENDIF ENDIF SEGSUP AXE IF (OLDAXE.NE.0) SEGSUP OLDAXE SEGSUP COM IF (DYN.NE.0) SEGSUP DYN IF (CUR.NE.0) SEGSUP CUR * RETURN END