C @(#)plotree.for 17.1.1.1 (ES0-DMD) 01/25/02 17:16:50 C=========================================================================== C Copyright (C) 1995 European Southern Observatory (ESO) C C This program is free software; you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation; either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public C License along with this program; if not, write to the Free C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, C MA 02139, USA. C C Corresponding concerning ESO-MIDAS should be addressed as follows: C Internet e-mail: midas@eso.org C Postal address: European Southern Observatory C Data Management Division C Karl-Schwarzschild-Strasse 2 C D 85748 Garching bei Muenchen C GERMANY C=========================================================================== C C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,TKLAB C all rights reserved C.IDENTIFICATION: PLOTREE C.VERSION: 1.0 ESO-FORTRAN Conversion, AA 12:54 - 16 NOV 1987 C.LANGUAGE: F77+ESOext C.PURPOSE: Plots table tree C.AUTHOR: J.D. Ponz, ESO Garching C.NOTE: PLOTTBL uses the plotting routines available in the plot library C which again uses the low level AGL routines. C.VERSION: 860625 J.D. Ponz creation C.VERSION: 870515 R.H. Warmels general update of code; new plot library C.VERSION: 880420 R.H. Warmels addapted to portable version of MIDAS C --------------------------------------------------------------------- C PROGRAM PLTTRE ! program PLTTRE *** main body *** C INTEGER MADRID INTEGER ILOG,PMODE,FMODE INTEGER NCOLUM,NROW,INADD(5),COL(4),TID REAL FRAME(8),SCALES(2) CHARACTER XFRAME*4,YFRAME*4 CHARACTER TABLE*60,SEL*64 CHARACTER LABEL1*80,LABEL2*80,LABEL3*80,TEXT*80 CHARACTER*16 LABEL(4),UNIT(4),OLAB CHARACTER*40 COLUMN(4) C COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:PLTDEC.INC/NOLIST' INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST' C INCLUDE 'MID_INCLUDE:PLTDAT.INC/NOLIST' INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST' C DATA SEL/' '/ DATA ILOG/0/ DATA NCOLUM/4/ DATA PMODE/0/ C 9000 FORMAT (I4) C C *** start executable code CALL STSPRO('PLOTTRE') !start comm. with MIDAS CALL STKRDI('PLISTAT',1,1,IAC,FMODE,KUN,KNUL,IST) !get the plot mode CALL STKRDC('PLCSTAT',1,5,4,IAC,XFRAME,KUN,KNUL,IST) !frame in x CALL STKRDC('PLCSTAT',1,9,4,IAC,YFRAME,KUN,KNUL,IST) !frame in y C C *** read parameters CALL STKRDC('P1',1,1,60,ITBL,TABLE,KUN,KNUL,ISTAT) !get table name IF (ISTAT.NE.0) THEN ! take action in case of trouble TEXT = '*** FATAL: Problems with table parameter '//TABLE CALL STTPUT(TEXT,ISTAT) CALL STSEPI ! stop communication with MIDAS STOP END IF C C *** read columns CALL STKRDC('P3',1,1,40,NCOL1,COLUMN(1),KUN,KNUL,ISTAT) ! first column CALL STKRDC('P2',1,1,40,NCOL2,COLUMN(2),KUN,KNUL,ISTAT) ! second column CALL STKRDC('P5',1,1,40,NCOL3,COLUMN(3),KUN,KNUL,ISTAT) ! third column CALL STKRDC('P4',1,1,40,NCOL4,COLUMN(4),KUN,KNUL,ISTAT) ! forth column C C *** this procedure read the table CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT) IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with opening table '//TABLE CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF C CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,ISTAT) ! read table information IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with getting table info' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF C IF (NROW.LE.0) THEN CALL STTPUT(' No points in the table ... ',ISTAT) CALL STSEPI STOP END IF C CALL TDRSEL(TID,SEL,ISTAT) ! table selection C C *** get column adresses DO 10 I = 1,NCOLUM CALL TBCSER(TID,COLUMN(I),COL(I),ISTAT) ! find column no. IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with finding column' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF IF (COL(I).EQ.-1) THEN ! problems during execution TEXT = '*** FATAL: Problems with finding column' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF C CALL TBCMAP(TID,COL(I),INADD(I),ISTAT) ! get column adress IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with mapping column' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF IF (COL(I).NE.0) THEN ! read label CALL TBLGET(TID,COL(I),LABEL(I),ISTAT) IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with reading column' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF C CALL TBUGET(TID,COL(I),UNIT(I),ISTAT) ! read units IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with reading units' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF END IF 10 CONTINUE C CALL TBCMAP(TID,0,INADD(5),ISTAT) ! select mask of the table IF (ISTAT.NE.0) THEN ! problems during execution TEXT = '*** FATAL: Problems with the table selection' CALL STTPUT(TEXT,ISTAT) CALL STSEPI STOP END IF C C ... set up labels OLAB = 'COLUMN ' IF (LABEL(1) (1:2).EQ.' ') THEN WRITE (OLAB(7:10),9000) COL(1) ELSE OLAB = LABEL(1) END IF LABEL1 = OLAB LABEL1(31:50) = ' ('//UNIT(1)//')' C C *** the y axis OLAB = 'COLUMN ' IF (LABEL(2) (1:2).EQ.' ') THEN WRITE (OLAB(7:10),9000) COL(2) ELSE OLAB = LABEL(2) END IF LABEL2 = OLAB LABEL2(31:50) = ' ('//UNIT(2)//')' C C *** get the scales CALL STKRDR('INPUTR',1,2,NVAL,SCALES,KUN,KNUL,ISTAT) SCALES(1) = ABS(SCALES(1)) SCALES(2) = ABS(SCALES(2)) CALL STKWRR('PLRSTAT',SCALES,19,2,KUN,ISTAT) C C *** calculate frame IF (XFRAME(1:4).EQ.'MANU') THEN ! man. scaling CALL STKRDR('PLRSTAT',11,4,NVAL,FRAME,KUN,KNUL,ISTAT) ! get frame par. ELSE ! auto scaling XFRAME = 'AUTO' CALL TDMXRS(NROW,MADRID(INADD(2)),MADRID(INADD(5)), ! min and max + ILOG,XMIN1,XMAX1) CALL TDMXRS(NROW,MADRID(INADD(4)),MADRID(INADD(5)), ! min and max + ILOG,XMIN2,XMAX2) FRAME(1) = MIN(XMIN1,XMIN2) FRAME(2) = MAX(XMAX1,XMAX2) IF (FRAME(1).EQ.FRAME(2)) THEN FRAME(2) = FRAME(1) + 1. END IF END IF C IF (YFRAME(1:4).EQ.'MANU') THEN ! man. scaling CALL STKRDR('PLRSTAT',15,4,NVAL,FRAME(5),KUN,KNUL,ISTAT) ! get frame ELSE ! auto scaling YFRAME = 'AUTO' CALL TDMXRS(NROW,MADRID(INADD(1)),MADRID(INADD(5)), ! min and max + ILOG,YMIN1,YMAX1) CALL TDMXRS(NROW,MADRID(INADD(3)),MADRID(INADD(5)), ! min and max + ILOG,YMIN2,YMAX2) FRAME(5) = MIN(YMIN1,YMIN2) FRAME(6) = MAX(YMAX1,YMAX2) IF (FRAME(5).EQ.FRAME(6)) THEN FRAME(6) = FRAME(5) + 1 END IF END IF C C *** get the scales CALL GETFRM(FRAME(1),FRAME(2),FRAME(3),FRAME(4),XFRAME) CALL GETFRM(FRAME(5),FRAME(6),FRAME(7),FRAME(8),YFRAME) CALL STKWRR('PLRSTAT',FRAME,11,8,KUN,ISTAT) C C *** do the plot setup CALL PLOPN(TABLE,PMODE,FMODE) C C *** do the work CALL PLTRE(NCOLUM,MADRID(INADD(1)),MADRID(INADD(2)), 2 MADRID(INADD(3)),MADRID(INADD(4)),MADRID(INADD(5)), 3 NROW) C IF (FMODE.GE.1) THEN CALL PLFRAM(FRAME(1),FRAME(2),FRAME(3),FRAME(4), 2 FRAME(5),FRAME(6),FRAME(7),FRAME(8)) IF (PMODE.EQ.1 .OR. PMODE.EQ.3) THEN LABEL3 = 'Table: '//TABLE CALL PLLABL(LABEL2,LABEL1,LABEL3,SEL) ELSE CALL PLLABL(LABEL1,LABEL2,' ',' ') CALL PLTREI(TABLE,COLUMN(2),COLUMN(1),COLUMN(4), 2 COLUMN(3),SEL) END IF END IF C C *** good bye and finish CALL TBTCLO(TID,ISTAT) CALL PLCLS CALL STSEPI ! stop communication with MIDAS END SUBROUTINE PLTRE(NCOLUM,V1,V2,V3,V4,V5,NROW) C+++ C.PURPOSE: Low level routine to plot a table treee C.AUTHOR: Rein H. Warmels C.VERSION: 86???? JDP Creation C.VERSION: 860625 RHW new routine based on Daniel's work C.VERSION: 861216 RHW inclusion of neg. increments C.VERSION: 87???? RHW restructure of code C.VERSION: 890118 RHW ST interfaces implemented C.COMMENTS: none C--- INTEGER NCOLUM ! # of columns to be plotted REAL V1(NROW) ! adress of first column to be plotted REAL V2(NROW) ! adress of second column to be plotted REAL V3(NROW) ! adress of third column to be plotted REAL V4(NROW) ! adress of fourth column to be plotted REAL V5(NROW) ! adress INTEGER NROW ! number of row C INTEGER TINULL REAL XX(2),YY(2) REAL TBLSEL, TRNULL DOUBLE PRECISION TDNULL, TDTRUE, TDFALS LOGICAL IPLOT C INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST' INCLUDE 'MID_INCLUDE:PLTDEC.INC/NOLIST' COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST' C C *** get machine constants CALL TBMNUL(TINULL, TRNULL, TDNULL) CALL TBMCON(TBLSEL, TDTRUE, TDFALS) C C *** do the work DO 10 I = 1,NROW IPLOT = .TRUE. IF (V5(I).EQ.TBLSEL) THEN YY(1) = V1(I) IF (YY(1).EQ.TRNULL) IPLOT = .FALSE. XX(1) = V2(I) IF (XX(1).EQ.TRNULL) IPLOT = .FALSE. YY(2) = V3(I) IF (YY(2).EQ.TRNULL) IPLOT = .FALSE. XX(2) = V4(I) IF (XX(2).EQ.TRNULL) IPLOT = .FALSE. IF (IPLOT) THEN CALL PLLINW(XX,YY,2) END IF END IF 10 CONTINUE C RETURN END SUBROUTINE PLTREI(FILE,COL1,COL2,COL3,COL4,SEL) C+++ C.PURPOSE: Produce plot information for a table tree plot C.AUTHOR: Rein H. Warmels C.COMMENTS: none C.VERSION: 880420 RHW Update for portable MIDAS C.VERSION: 890118 RHW ST interfaces implemented C.COMMENTS: none C--- CHARACTER*(*) FILE !name of the table CHARACTER*(*) COL1 !name of x column CHARACTER*(*) COL2 !name of x column CHARACTER*(*) COL3 !name of x column CHARACTER*(*) COL4 !name of y column CHARACTER*(*) SEL !selection string C CHARACTER BUF*80 CHARACTER NUMB5*10,NUMB6*10 REAL SCALES(2) REAL XL(3),YL(3) INCLUDE 'MID_INCLUDE:PLTDEC.INC/NOLIST' C 9010 FORMAT (G10.3) C C *** X1 = GX2 + 0.01 X2 = 1.0 Y1 = 0.0 Y2 = GY2 CALL AGSSET('LINX') CALL AGSSET('LINY') CALL AGCDEF(X1,X2,Y1,Y2) CALL AGWDEF(0.0,1.0,0.0,1.0) C CALL PLLOGI(XT,YT) ! plot the MIDAS LOGO C C *** get character size CALL AGTGET('M',XL,YL) YH = 2.0*YL(2) C C *** table name BUF = 'Table:' CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = FILE CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) C C *** columns YT = YT - 2*YH BUF = 'Columns: ' CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = 'X1: '//COL1 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = 'Y1: '//COL2 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = 'X2: '//COL3 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = 'Y2: '//COL4 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) C C *** scales YT = YT - 2*YH BUF = 'Scales: ' CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH NUMB5 = ' ' NUMB6 = ' ' CALL STKRDR('PLRSTAT',19,2,IAC,SCALES,KUN,KNUL,IST) WRITE (NUMB5(1:10),9010) SCALES(1) WRITE (NUMB6(1:10),9010) SCALES(2) BUF = 'X: '//NUMB5 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) YT = YT - YH BUF = 'Y: '//NUMB6 CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) C C *** selection YT = YT - 2*YH BUF = 'Selection:' CALL LENBUF(BUF,L) CALL AGGTXT(XT,YT,BUF(1:L),1) C IF ((SEL(1:1).EQ.'-') .OR. (SEL(1:1).EQ.' ')) THEN ! no selection BUF = 'all' CALL LENBUF(BUF,L) YT = YT - YH CALL AGGTXT(XT,YT,BUF(1:L),1) ELSE ISTART = 1 10 CONTINUE ! check for logicals IDXOR = INDEX(SEL(ISTART:),'.OR.') IF (IDXOR.NE.0) THEN IDXOR = ISTART + IDXOR + 2 ELSE IDXOR = 999 END IF IDXAND = INDEX(SEL(ISTART:),'.AND.') IF (IDXAND.NE.0) THEN IDXAND = ISTART + IDXAND + 3 ELSE IDXAND = 999 END IF IEND = MIN(IDXOR,IDXAND) IF (IEND.EQ.999) THEN ! no logicals in selection CALL LENBUF(SEL(ISTART:),LSEL) ! length of the whole string NLINE = LSEL/20 ! number of lines needed NREST = LSEL - NLINE*20 ! number of remaining characters DO 20 I = 1,NLINE ! loop through lines IS = ISTART + (I-1)*20 ! start index IE = IS + 19 ! end index BUF = SEL(IS:IE) ! store in buffer CALL LENBUF(BUF,L) ! length of string in buffer YT = YT - YH CALL AGGTXT(XT,YT,BUF(1:L),1) ! put text 20 CONTINUE ! end loop BUF = SEL(ISTART+NLINE*20:) CALL LENBUF(BUF,L) ! length of buffer YT = YT - YH CALL AGGTXT(XT,YT,BUF(1:L),1) ! put the text GO TO 40 ELSE ! selection includes logicals CALL LENBUF(SEL(ISTART:IEND),L) ! length of the buffer NLINE = L/20 ! number of full lines NREST = L - NLINE*20 ! number of remaining characters DO 30 I = 1,NLINE ! loop through lines IS = ISTART + (I-1)*20 ! start index IE = IS + 19 ! end index BUF = SEL(IS:IE) ! fill buffer CALL LENBUF(BUF,L) ! length of buffer YT = YT - YH CALL AGGTXT(XT,YT,BUF(1:L),1) ! put the text 30 CONTINUE ! end of loop BUF = SEL(ISTART+NLINE*20:IEND) CALL LENBUF(BUF,L) ! length of buffer YT = YT - YH CALL AGGTXT(XT,YT,BUF(1:L),1) ! put the text ISTART = IEND + 1 ! determine next string GO TO 10 END IF END IF 40 CONTINUE C YT = YT - 2.0*YH CALL PLDATI(XT,YT) RETURN END