C @(#)plotree.for	19.1 (ES0-DMD) 02/25/03 13:27:33
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                                                                       
