C TBMAIN SOURCE GOUNAND 25/04/22 21:15:16 12244 * PERMET D'AFFICHER SUR ECRAN OU IMPRIMANTE * UN TABLEAU. *************************************************** * ** LISTE DES FONCTIONS ET PROCEDURES: *************************************************** * * TABLEAU SUBROUTINE PRINCIPALE * EGALE (X,Y,P) FONCTION QUI RENVOIT .TRUE. SI LES * DEUX REAL*8 X ET Y SONT EGAUX A P PRES. * EFFACER PERMET D'EFFACER LA FENETRE GRAPHIQUE * EN REINITIALISANT LE SEGMENT POUR IMPRESSION. * NTAFFICHE AFFICHE LES ENTETES D'UN TABLEAU * NAFFICHE AFFICHE UNE CASE * AFFICHE AFFICHE UNE PAGE * TRINI ET SES FONCTIONS * SUBROUTINE TBMAIN IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC CCGEOME -INC SMLENTI -INC SMLMOTS -INC TMNTAB *************************************************** * ** LISTE DES VARIABLES : *************************************************** * LPARAM LISTE DES PARAMETRES A LIRE * NPARAM NOMBRE DE PARAMETRES DANS LA LISTE * LEGEND TABLEAU DE CHAINE POUR LES MENUS * EV POINTEUR SUR UNE EVOLUTION * NBEVOL NOMBRE DE COURBES DANS L'OJET EVOLUTION * CURPX PAGE COURANTE EN X * CURPY PAGE COURANTE EN Y * ITABX NOMBRE DE COLONNES DE L'OBJET TABTR * ITABY NOMBRE DE LIGNES DE L'OBJET TABTR * NBPX NOMBRE DE PAGES EN X * NBPY NOMBRE DE PAGES EN Y * NBPAGE NOMBRE DE PAGES DE L'OBJET TABTR * TABTR SEGMENT POUR LE TABLEAU *************************************************** * ** DEFINITION DES VARIABLES: *************************************************** LOGICAL VALEUR,ZN,ZD CHARACTER*128 TMPCAR POINTEUR EV.MEVOLL POINTEUR LI.MLENTI REAL*8 EPSILN,RA,RB CHARACTER*10 LPARAM (17) INTEGER NPARAM CHARACTER*25 LEGEND (6) INTEGER CURPX,CURPY,FX,FY INTEGER ITABX,ITABY INTEGER PAGESX,PAGESY,NBPX,NBPY INTEGER NUM,NUM2 *************************************************** * ** INITIALISATION DES VARIABLES: *************************************************** DATA LPARAM /'TITR','STITR','TCOL','TLIG','NOCENTER', # 'NOLIG','NODATE','TEXCOU','LIGCOU','COLCOU','TITCOU', # 'TRILIG','TRICOL','VERTICAL','PAGE','NOPAGE','LOGO'/ NPARAM = 17 EPSILN = DBLE (0) ITABX = 0 ITABY = 0 TABTR = 0 LI = 0 *************************************************** * ** LECTURE DES OBJETS *************************************************** * * EVOLUTION * CALL LIROBJ ('EVOLUTIO',IRET,0,IRETOU) IF (IRETOU.EQ.1) THEN CALL EVLIRE ( IRET, TABTR, EPSILN,ITABX, ITABY) IF (TABTR.EQ.0) GOTO 1000 SEGACT TABTR*MOD GOTO 200 ENDIF * * CHAMP PAR POINT * CALL LIROBJ ('CHPOINT',IRET,0,IRETOU) IF (IRETOU.EQ.1) THEN CALL CHLIRE ( IRET, TABTR, EPSILN,ITABX, ITABY) IF (TABTR.EQ.0) GOTO 1000 SEGACT TABTR*MOD GOTO 200 ENDIF * * CHAMP PAR ELEMENT * CALL LIROBJ ('MCHAML',IRET,0,IRETOU) IF (IRETOU.EQ.1) THEN CALL CELIRE ( IRET, TABTR, EPSILN,ITABX, ITABY) IF (TABTR.EQ.0) GOTO 1000 SEGACT TABTR*MOD GOTO 200 ENDIF * * PAS D'OBJET * GOTO 1000 *************************************************** * ** INITIALISATION PAR DEFAUT DE TABTR *************************************************** 200 CONTINUE * * INITIALISE LA DEFINITION DES PAGES DU TABLEAU * IF (ZHORIZ) THEN CALL TBPAYS (NBPX, NBPY, TABTR, ITABX,ITABY) ELSE CALL TBPORT (NBPX, NBPY, TABTR, ITABX,ITABY) ENDIF * REGARDE S'IL FAUT METTRE LES NUMEROS DE PAGES IF (TABTR.PX*TABTR.PY.GT.1) THEN TABTR.ZPAGE = .TRUE. ELSE TABTR.ZPAGE = .FALSE. ENDIF *************************************************** * ** LECTURE DES MOTS CLE: POST TRAITEMENT DU TABLEAU *************************************************** 400 CONTINUE CALL LIRMOT (LPARAM,NPARAM,INDICE,0) IF (INDICE.NE.0) THEN GOTO (405,410,415,420,425,430,435,440,445,450,455, # 460,465,470,475,480,485),INDICE * * MODIFICATION DU TITRE * 405 CONTINUE CALL LIRCHA (TMPCAR,1,IRETOU) TABTR.TITGEN = TMPCAR GOTO 400 * * MODIFICATION DU SOUS TITRE * 410 CONTINUE CALL LIRCHA (TMPCAR,1,IRETOU) TABTR.SSTITR = TMPCAR GOTO 400 * * MODIFICATION DU TITRE D'UNE COLONNE * 415 CONTINUE CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU) IF (IRETOU.NE.1) THEN CALL LIRENT ( NUM, 1,IRETOU) CALL LIRCHA ( TMPCAR,1,IRETOU) IF (TABTR.EQ.0) GOTO 400 IF ( (NUM.LT.1).OR. (NUM.GT.ITABX)) GOTO 400 TABTR.ELEM (NUM,1) = TMPCAR TABTR.TITCOL (NUM) = TMPCAR ELSE IF (TABTR.EQ.0) GOTO 400 SEGACT MLMOTS DO I=1,MOTS(/2) TMPCAR=' ' TMPCAR=MOTS(I) IF (I.GT.ITABX) GOTO 400 TABTR.ELEM (I,1) = TMPCAR TABTR.TITCOL (I) = TMPCAR ENDDO ENDIF IF (TABTR.EQ.0) GOTO 400 IF (ZHORIZ) THEN CALL TBPAYS ( NBPX, NBPY, TABTR, ITABX,ITABY) ELSE CALL TBPORT ( NBPX, NBPY, TABTR, ITABX,ITABY) ENDIF GOTO 400 * * MODIFICATION DU TITRE D'UNE LIGNE * 420 CONTINUE CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU) IF (IRETOU.NE.1) THEN CALL LIRENT ( NUM, 1, IRETOU) CALL LIRCHA ( TMPCAR,1,IRETOU) IF (TABTR.EQ.0) GOTO 400 IF ( (NUM.LT.1).OR. (NUM.GT.ITABY)) GOTO 400 TABTR.ELEM (1,NUM) = TMPCAR ELSE IF (TABTR.EQ.0) GOTO 400 SEGACT MLMOTS DO I=1,MOTS(/2) TMPCAR=' ' TMPCAR=MOTS(I) IF (I.GT.ITABY) GOTO 400 TABTR.ELEM (1,I) = TMPCAR ENDDO ENDIF GOTO 400 * * NE PAS CENTRER LES TABLEAUX * 425 CONTINUE TABTR.ZCTRER = .FALSE. GOTO 400 * * NE PAS FAIRE L'ENCADREMENT AUTOMATIQUE * 430 CONTINUE TABTR.ZAULIG = .FALSE. GOTO 400 * * ENLEVER LA DATE * 435 CONTINUE ZD = .FALSE. TABTR.ZDATE = .FALSE. GOTO 400 * * CHANGER LA COULEUR DU TEXTE * 440 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) TABTR.ITEXC = NUM GOTO 400 * * CHANGER LA COULEUR DES ENCADREMENTS * 445 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) TABTR.ILIGC = NUM GOTO 400 * * CHANGER LA COULEUR DES TITRES DE COLONNES * 450 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) TABTR.ICOLC = NUM GOTO 400 * * CHANGER LA COULEUR DES TITRES * 455 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) TABTR.ITITC = NUM GOTO 400 * * TRIER LES LIGNES * 460 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) IF ( (NUM.LT.1).OR. (NUM.GT.ITABX)) GOTO 400 CALL TBTRLI ( NUM,3, TABTR, ITABX, ITABY) GOTO 400 * * TRIER LES COLONNES * 465 CONTINUE CALL LIRENT ( NUM, 1, IRETOU) IF ( (NUM.LT.1).OR. (NUM.GT.ITABY)) GOTO 400 CALL TBTRCO ( NUM,3, TABTR, ITABX, ITABY) GOTO 400 * * PASSER EN MODE PORTRAIT * 470 CONTINUE if (ZINIPS) CALL TBPORT ( NBPX, NBPY, TABTR, ITABX,ITABY) GOTO 400 * * FORCER L'AFFICHAGE DES NUMEROS DE PAGE * 475 CONTINUE TABTR.ZPAGE = .TRUE. GOTO 400 * * FORCER LE NON AFFICHAGE DES NUMEROS DE PAGES * 480 CONTINUE TABTR.ZPAGE = .FALSE. GOTO 400 * * INSERER LE LOGO * 485 CONTINUE TABTR.ZLOGO = .TRUE. GOTO 400 * ENDIF *************************************************** * ** AFFICHAGE DE LA FENETRE *************************************************** * SG 2016/06/2016 *old IF (IOGRA.EQ.1) GOTO 900 *old IF (IOGRA.EQ.7) GOTO 900 *old IF (IOGRA.EQ.8) GOTO 900 * IOGRA 1 LGI 2 XWINDOW 6 OPENGL 7 POSTSCRIPT 8 MIF 9 POSTSCRIPT COULEUR IF (.NOT.(IOGRA.EQ.2.OR.IOGRA.EQ.6)) GOTO 900 * INITIALISATION DU NOMBRE DE COULEURS if (ZHORIZ) then CALL TRINIT (24,29.7d0,21.d0,' ',1.,VALEUR,NCOUMA) else CALL TRINIT (24,21.d0,29.7d0,' ',1.,VALEUR,NCOUMA) endif CURPX = 1 CURPY = 1 * *************************************************** * ** CREATION DU MENU: ATTENTE DES ORDRES *************************************************** 600 CONTINUE * * AFFICHAGE MENU PRINCIPAL * 602 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)='Fin dessin' LEGEND (2)=' Suivante ' LEGEND (3)='Precedante' LEGEND (4)='Options >>' IF (ZHORIZ) THEN LEGEND (5)='Hor/Vert (H)' ELSE LEGEND (5)='Hor/Vert (V)' ENDIF CALL MENU (LEGEND,5,12) CALL TRAFF (ICLE) * FIN DESSIN IF (ICLE.EQ.0) GOTO 1000 * AFFICHER LA PAGE SUIVANTE IF (ICLE.EQ.1) THEN CURPX = CURPX+1 IF (CURPX.EQ. (NBPX+1)) THEN CURPX=1 CURPY=CURPY+1 IF (CURPY.EQ. (NBPY+1)) THEN CURPY=1 ENDIF ENDIF ENDIF * AFFICHER LA PAGE PRECEDANTE IF (ICLE.EQ.2) THEN CURPX = CURPX - 1 IF (CURPX.EQ.0) THEN CURPX = NBPX CURPY = CURPY -1 IF (CURPY.EQ.0) THEN CURPY = NBPY ENDIF ENDIF ENDIF * OPTIONS IF (ICLE.EQ.3) GOTO 610 * BASCULER IF (ICLE.EQ.4) THEN IF (ZINIPS) THEN NBPX = 0 NBPY = 0 IF (ZHORIZ) THEN CALL TBPORT ( NBPX, NBPY, TABTR ,ITABX,ITABY) ELSE CALL TBPAYS ( NBPX, NBPY, TABTR, ITABX,ITABY) ENDIF CURPX = 1 CURPY = 1 ENDIF ENDIF * RETOUR GOTO 602 * * SOUS MENU OPTIONS * 610 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)=' << options' LEGEND (2)=' Arranger >>' LEGEND (3)='Encadrement >>' LEGEND (4)=' Titres >>' LEGEND (5)=' Couleurs >>' LEGEND (6)=' Divers >>' CALL MENU (LEGEND,6,16) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) THEN CALL TBAFF ( CURPX, CURPY, TABTR ) GOTO 602 ENDIF * TRIER IF (ICLE.EQ.1) GOTO 620 * ENCADREMENT IF (ICLE.EQ.2) GOTO 630 * TITRES IF (ICLE.EQ.3) GOTO 640 * COULEURS IF (ICLE.EQ.4) GOTO 650 * DIVERS IF (ICLE.EQ.5) GOTO 710 * RETOUR GOTO 610 * * SOUS MENU ARANGER * 620 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)=' << Aranger' LEGEND (2)='Trier Colonnes >>' LEGEND (3)=' Trier Lignes >>' LEGEND (4)=' Modifier >>' CALL MENU (LEGEND,4,17) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) GOTO 610 * TRIER LES COLONNES IF (ICLE.EQ.1) GOTO 700 * TRIER LES LIGNES IF (ICLE.EQ.2) GOTO 690 * MODIFIER IF (ICLE.EQ.3) GOTO 730 * RETOUR GOTO 620 * * SOUS MENU ENCADREMENT * 630 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)='<< encadrement' LEGEND (2)='inter Colonnes >>' LEGEND (3)='inter Lignes >> ' LEGEND (4)=' Cellule >> ' CALL MENU (LEGEND,4,18) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) GOTO 610 * INTER COLONNE IF (ICLE.EQ.1) THEN GOTO 680 ENDIF * INTER LIGNE IF (ICLE.EQ.2) THEN GOTO 660 ENDIF * CELLULE IF (ICLE.EQ.3) THEN GOTO 670 ENDIF * RETOUR GOTO 630 * * SOUS MENU TITRES * 640 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)=' << titres' LEGEND (2)=' General ' LEGEND (3)='Sous titre' LEGEND (4)=' Colonne ' LEGEND (5)=' Ligne ' CALL MENU (LEGEND,5,10) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) GOTO 610 * CHANGER LE TITRE DU TABLEAU IF (ICLE.EQ.1) THEN CALL TRGET ('Entrer le nouveau titre:',TMPCAR) TABTR.TITGEN=TMPCAR CALL TBAFF ( CURPX, CURPY, TABTR) ENDIF * CHANGER LE SOUS TITRE IF (ICLE.EQ.2) THEN CALL TRGET ('Entrer le nouveau sous-titre:',TMPCAR) TABTR.SSTITR=TMPCAR CALL TBAFF ( CURPX, CURPY, TABTR) ENDIF * CHANGER LE TITRE D'UNE COLONNE IF (ICLE.EQ.3) THEN CALL TRMESS ('Cliquer sur la colonne.') CALL TBGTXY (CURPX,CURPY,TABTR,IX,IY,FX,FY) IF ( (IX.LT.1).OR. (IX.GT.ITABX)) THEN CALL TRMESS ('Emplacement invalide') GOTO 640 ENDIF CALL TRGET ('Entrer le nouveau titre de colonne:',TMPCAR) TABTR.ELEM (IX,1) = TMPCAR TABTR.TITCOL (IX) = TMPCAR CALL TBTRHT (TABTR,ITABX) IF (ZHORIZ) THEN CALL TBPAYS ( NBPX, NBPY, TABTR, ITABX,ITABY) ELSE CALL TBPORT ( NBPX, NBPY, TABTR, ITABX,ITABY) ENDIF CALL TBAFF ( CURPX, CURPY, TABTR) ENDIF * CHANGER LE TITRE D'UNE LIGNE IF (ICLE.EQ.4) THEN CALL TRMESS ('Cliquer sur la ligne.') CALL TBGTXY (CURPX,CURPY,TABTR,IX,IY,FX,FY) IF ( (IY.LT.1).OR. (IY.GT.ITABY)) THEN CALL TRMESS ('Emplacement invalide') GOTO 640 ENDIF CALL TRGET ('Entrer le nouveau titre de ligne:',TMPCAR) TABTR.ELEM (1,IY) = TMPCAR CALL TBAFF ( CURPX, CURPY, TABTR) ENDIF * RETOUR GOTO 640 * * SOUS MENU COULEURS * 650 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)=' << couleurs' LEGEND (2)=' Texte ' LEGEND (3)='Encadrement ' LEGEND (4)=' Colonnes ' LEGEND (5)=' Titres ' LEGEND (6)=' Logo ' CALL MENU (LEGEND,6,12) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) GOTO 610 * TEXTE IF (ICLE.EQ.1) THEN NUM=NBCOUL CALL TRGETC (NUM) TABTR.ITEXC = NUM CALL TBAFF ( CURPX, CURPY, TABTR) ENDIF * ENCADREMENT IF (ICLE.EQ.2) THEN NUM=NBCOUL CALL TRGETC (NUM) TABTR.ILIGC = NUM ENDIF * COLONNES IF (ICLE.EQ.3) THEN NUM=NBCOUL CALL TRGETC (NUM) TABTR.ICOLC = NUM ENDIF * TITRES IF (ICLE.EQ.4) THEN NUM=NBCOUL CALL TRGETC (NUM) TABTR.ITITC = NUM ENDIF * LOGO IF (ICLE.EQ.5) THEN NUM=NBCOUL CALL TRGETC (NUM) TABTR.ILOGC = NUM ENDIF * RETOUR GOTO 650 * * SOUS MENU ENCADREMENT INTER LIGNE * 660 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)='<< encadrement-lignes' LEGEND (2)=' Normal ' LEGEND (3)=' Gras ' LEGEND (4)=' Enlever ' CALL MENU (LEGEND,4,22) CALL TRAFF (ICLE) * REVENIR IF (ICLE.EQ.0) GOTO 630 * NORMAL IF (ICLE.EQ.1) THEN CALL TRMESS ('Cliquer sur la ligne.') CALL TBGTXY (CURPX,CURPY,TABTR,IX,IY,FX,FY) IF (IY.EQ.0) IY=TABTR.CIDY (CURPX,CURPY)+1 DO 662 IX=1 , ITABX TABTR.ZHSEP (IX,IY) = .TRUE. TABTR.ZGHSEP (IX,IY) = .FALSE. 662 CONTINUE ENDIF * GRAS IF (ICLE.EQ.2) THEN CALL TRMESS ('Cliquer sur la ligne.') CALL TBGTXY (CURPX,CURPY,TABTR,IX,IY,FX,FY) IF (IY.EQ.0) IY=TABTR.CIDY (CURPX,CURPY)+1 DO 664 IX=1 , ITABX TABTR.ZHSEP (IX,IY) = .TRUE. TABTR.ZGHSEP (IX,IY) = .TRUE. 664 CONTINUE ENDIF * ENLEVER IF (ICLE.EQ.3) THEN CALL TRMESS ('Cliquer sur la ligne.') CALL TBGTXY (CURPX,CURPY,TABTR,IX,IY,FX,FY) IF (IY.EQ.0) IY=TABTR.CIDY (CURPX,CURPY)+1 DO 666 IX=1 , ITABX TABTR.ZGHSEP (IX,IY) = .FALSE. TABTR.ZHSEP (IX,IY) = .FALSE. 666 CONTINUE ENDIF * RETOUR GOTO 660 * * SOUS MENU ENCADREMENT CELLULE * 670 CONTINUE CALL TBAFF ( CURPX, CURPY, TABTR ) LEGEND (1)='<