C @(#)tloadtbl.for	17.1.1.1 (ESO-IPG) 01/25/02 17:40:02
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 Massachusetts Ave, Cambridge,
C MA 02139, USA.
C
C Correspondence 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
      PROGRAM TLOADTBL
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  20:55 - 16 DEC 1987
C.VERSION: 1.1  881118  KB
C               891213 MP
C   1.20   900928
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.Ponz
C
C.IDENTIFICATION:
C  program TLOADTBL
C
C.KEYWORDS:
C  display, table subsystem
C
C.PURPOSE:
C  Display table positions in the overlay plane of the display window
C 
C  Execute the command
C
C  LOAD/TAB table column1 column2 [column3] [symbol [size [level]]]
C
C.ALGORITHM:
C  plot table entries as : square    (0,2)
C                          circles     (1)
C                          triangle up (3), triangle down (4)
C                          cross       (5), open cross    (6)
C                          diamond     (7)
C                          X shaped cross (8)
C  for squares, triangles, circles and diamonds exist a filled option (add 100)
C  thus filled diamonds have value (107)
C
C.INPUT/OUTPUT:
C  the following keywords are used:
C
C.VERSIONS
C  1.20		consider that it only works if there's a frame loaded before!
C 
C 010202		last modif
C 
C-------------------------------------------------------------------
C
C
      IMPLICIT NONE
C 
      INTEGER MADRID(1)
      INTEGER IC,I,J,ILEN
      INTEGER SELROW             ! index for selected rows 
      INTEGER NROW,NSC,IAV,NVAL
      INTEGER ISYMBOL,NODRAW,FILL
      INTEGER NCOL,NACOL,NAROW
      INTEGER INTEN,OVCON
      INTEGER ICOL(6),INPAR(3)
      INTEGER STAT,IMNO,PRFLAG
      INTEGER CONN                ! connection flag, P8
      INTEGER TINULL, TID, KUN, KNUL
      INTEGER NBYTE,TYPE,MY
      INTEGER IX(512),IY(512),NPOS(2),LASTP(2)
      INTEGER COLSYM,COLSIZ,COLCOL
C
      REAL RBUF(6),XY1(2),XY2(2)
      REAL VALUE(3)
      REAL TRNULL,RINFO(8),RDUM
C
      DOUBLE PRECISION TDNULL
C
      CHARACTER*80  FRAME,LINE
      CHARACTER*80  TABLE
      CHARACTER*16  UNIT1,UNIT2
      CHARACTER     IFLAG*3,DLINE*40,LASTLINE*40,FORM*8
      CHARACTER*30  COLUMN(6)
      CHARACTER*2   PARM(6)
C
      LOGICAL ISEL,IPLOT,NULL(3)
C
      INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:IDIDEV.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:IDIMEM.INC/NOLIST'
C
      COMMON /VMR/MADRID
C
      INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST'
C
       DATA LINE/' '/,  DLINE /' '/
       DATA LASTLINE/' '/, FRAME /' '/, TABLE /' '/
       DATA PARM /'P2','P3','P4','P5','P6','P7'/
       DATA LASTP /0,0/
C
C  initialize MIDAS + attach ImageDisplay
      CALL STSPRO('TLOADTBL')
      CALL DTOPEN(1,STAT)
C
C   get info for relevant memory board + scroll overlay channel
C   accordingly then clear scroll values, so we also start 
C   plotting at the lower left corner
C
      CALL STKRDI('DAZHOLD',13,1,IAV,OVCON,KUN,KNUL,STAT)
      CALL DTGICH(QDSPNO,QIMCH,FRAME,RINFO,STAT)
      IF (FRAME(1:1).EQ.' ')
     +   CALL STETER(14,'We need an image in the display...!')
      CALL STFOPN(FRAME,D_R4_FORMAT,0,F_IMA_TYPE,IMNO,STAT)
      IF (OVCON.EQ.QIMCH)
     +   CALL DAZZSC(QDSPNO,QOVCH,ZOOMX,SCROLX,SCROLY,STAT)
      CALL STKRDI('MID$INFO',8,1,IAV,PRFLAG,KUN,KNUL,STAT)
C
C ... get parameters
C
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
      CALL STKRDC('IN_A',1,1,80,IAV,TABLE,KUN,KNUL,STAT)
      DO 10, I=1,6
         CALL STKRDC(PARM(I),1,1,30,IAV,COLUMN(I),KUN,KNUL,STAT)
10    CONTINUE
      NODRAW = 0
      IF (COLUMN(3)(1:1) .EQ. '+') THEN
          IC = 2                             !no IDENT column
      ELSE 
          IC = 3
          CALL UPCAS(COLUMN(3),LINE)         !check for NOdraw option
          I = INDEX(LINE,',NO')
          IF (I.GT.1) THEN
             NODRAW = 1
             COLUMN(3)(I:) = ' '             !clean column label
          ENDIF
      ENDIF 
      FILL = 0
      IF ((COLUMN(4)(1:1).EQ.'#').OR.(COLUMN(4)(1:1).EQ.':')) THEN
         COLSYM = 1                          !variable symbol from column
      ELSE
         COLSYM = 0                          !constant symbol
         CALL GENCNV(COLUMN(4),1,1,INPAR(1),RDUM,RDUM,IAV)
         IF (IAV.NE.1) INPAR(1) = 0
         IF (INPAR(1).GE.100) THEN
            FILL = 1
            INPAR(1) = INPAR(1) - 100
         ENDIF
         ISYMBOL = INPAR(1) + 1
      ENDIF
      IF ((COLUMN(5)(1:1).EQ.'#').OR.(COLUMN(5)(1:1).EQ.':')) THEN
         COLSIZ = 1                          !variable size from column
      ELSE
         COLSIZ = 0                          !constant size 
         CALL GENCNV(COLUMN(5),1,1,INPAR(2),RDUM,RDUM,IAV)
         IF (IAV.NE.1) INPAR(2) = 3
      ENDIF
      IF ((COLUMN(6)(1:1).EQ.'#').OR.(COLUMN(6)(1:1).EQ.':')) THEN
         COLCOL = 1                          !variable color from column
      ELSE
         COLCOL = 0                          !constant color
         CALL TSCOLR(COLUMN(6),INTEN)        !color string -> color no.
      ENDIF
C      
      CALL STKRDI('INPUTI',1,1,IAV,CONN,KUN,KNUL,STAT)
                               ! this will put P8 into CONN
C
C ... read table
C
      CALL TBTOPN(TABLE,F_I_MODE,TID,STAT)
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,STAT)
      DO 20, I=1,IC                               !search for x, y, ident cols
         CALL TBCSER(TID,COLUMN(I),ICOL(I),STAT)
         IF (ICOL(I).EQ.-1) CALL STETER(11,'Column not present')
20    CONTINUE
      IF (IC .EQ. 3) THEN                       ! if there is an ident col ...
         CALL TBFGET(TID,ICOL(3),FORM,ILEN,TYPE,STAT) ! ...get its type
      ENDIF
      CALL TBUGET(TID,ICOL(1),UNIT1,STAT)
      CALL TBUGET(TID,ICOL(2),UNIT2,STAT)
      CALL UPCAS(UNIT1,UNIT1)
      I = INDEX(UNIT1,'PIX')                 !that catches also "Frame Pixels"
      CALL UPCAS(UNIT2,UNIT2)
      J = INDEX(UNIT2,'PIX')
      IF ((I.GT.0).AND.(J.GT.0)) THEN
          IFLAG  = '_RS'
      ELSE
          IFLAG  = 'WRS'
      ENDIF
      IF (COLSYM.EQ.1) THEN
         CALL TBCSER(TID,COLUMN(4),ICOL(4),STAT)
         IF (ICOL(4).EQ.-1) CALL STETER(11,'Symbol column not present')
      ENDIF
      IF (COLSIZ.EQ.1) THEN
         CALL TBCSER(TID,COLUMN(5),ICOL(5),STAT)
         IF (ICOL(5).EQ.-1) CALL STETER(11,'Size column not present')
      ENDIF
      IF (COLCOL.EQ.1) THEN
         CALL TBCSER(TID,COLUMN(6),ICOL(6),STAT)
         IF (ICOL(6).EQ.-1) CALL STETER(11,'Color column not present')
      ENDIF
C
C  set up PIXXCV
      CALL PIXXCV('INIT',IMNO,RBUF,STAT)
      IF (STAT.NE.0)
     +   CALL STETER(12,'PIXXCV initialization failed...')
C
C ... display values
C
      NVAL = 0
      SELROW = 0
C 
      DO 40, I=1,NROW                   ! step through all rows
         CALL TBSGET(TID,I,ISEL,STAT)   ! read row selection flag
         CALL TBRRDR(TID,I,2,ICOL,VALUE,NULL,STAT)
         IPLOT  = ISEL .AND. ( .NOT. NULL(1)) .AND. ( .NOT. NULL(2))
         IF (IPLOT) THEN
            SELROW = SELROW + 1   
            IF (COLSYM.EQ.1) THEN
               FILL = 0
               CALL TBRRDI(TID,I,1,ICOL(4),INPAR(1),NULL,STAT)
               IF (INPAR(1).GT.100) THEN
                  FILL = 1
                  INPAR(1) = INPAR(1) - 100
               ENDIF
               ISYMBOL = INPAR(1) + 1
            ENDIF
            IF (COLSIZ.EQ.1) 
     +         CALL TBRRDI(TID,I,1,ICOL(5),INPAR(2),NULL,STAT)
            IF (COLCOL.EQ.1) 
     +         CALL TBRRDI(TID,I,1,ICOL(6),INTEN,NULL,STAT)
C
            RBUF(1) = VALUE(1)
            RBUF(2) = VALUE(2)
            CALL PIXXCV(IFLAG,0,RBUF,STAT)
            IF (STAT.NE.0) THEN
               IF (PRFLAG.EQ.99) WRITE(*,10077) I
               GOTO 40
            ENDIF
C 
            LINE(1:) = ' '
            IF (CONN.EQ.1) THEN        ! yes, connect the symbols 
               NVAL   = NVAL + 1
               IF (NVAL.GT.512) THEN                      !flush line buffer
                  CALL IIGPLY(QDSPNO,QOVCH,IX,IY,512,INTEN,1,STAT)
                  IX(1) = IX(512)
                  IY(1) = IY(512)
                  NVAL = 2
               ENDIF
               IX(NVAL) = NINT(RBUF(5))
               IY(NVAL) = NINT(RBUF(6))
            ENDIF
C 
            IF (ISYMBOL.GT.0) THEN
               XY1(1) = RBUF(5) - INPAR(2)
               XY1(2) = RBUF(6) - INPAR(2)
               XY2(1) = RBUF(5) + INPAR(2)
               XY2(2) = RBUF(6) + INPAR(2)
               CALL DRAWME(ISYMBOL,FILL,XY1,XY2,INTEN)
            ENDIF
C 
            IF (IC.EQ.3) THEN           ! yes, there is a third column as ident 
               IF (TYPE .EQ. D_C_FORMAT) THEN      !yes, its type is character
                  CALL TBERDC(TID,I,ICOL(3),LINE,NULL(3),STAT)
                  NBYTE = INDEX(LINE,' ') - 1
                  IF (NBYTE.GT.37) NBYTE = 37         ! DLINE is 40 chars.
                  DLINE(3:) = LINE(1:NBYTE)           ! fill DLINE
                  NBYTE = NBYTE + 2
               ELSE                    ! type of third column is not char!
                  CALL TBERDR(TID,I,ICOL(3),VALUE(3),NULL(3),STAT)
                  MY = NINT(VALUE(3))
                  WRITE (DLINE,9020) MY               ! fill DLINE
                  NBYTE = 4
               ENDIF
               DLINE(NBYTE+1:) = '^'                     !mark the end
C 
               NPOS(1) = NINT(RBUF(5))
               NPOS(2) = NINT(RBUF(6))

               IF (CONN.NE.0) THEN    
                                    ! connection flag P8 is +1 or -1
                  IF (NODRAW.EQ.0)
     +               CALL IIGTXT(QDSPNO,QOVCH,DLINE(1:NBYTE),
     +                           NPOS(1),NPOS(2),0,0,INTEN,0,STAT)
C     
               ELSE 
                                    ! CONN (P8) is zero (default)!        	    
                  IF (SELROW.EQ.1) THEN    
                                    ! if loop works on first row of table
                     LASTP(1) = NPOS(1)
                     LASTP(2) = NPOS(2)
                     LASTLINE(1:) = DLINE(1:)    !  LASTLINE set to DLINE
                  ENDIF
C	  
                  IF (LASTLINE.EQ.DLINE) THEN  !true, at least for first row
                     NVAL = NVAL + 1
                  ELSE                 ! LASTLINE not equal DLINE
                     IF (NVAL.GT.1) 
     +                  CALL IIGPLY(QDSPNO,QOVCH,IX,IY,NVAL,
     +                              INTEN,1,STAT)
                     NVAL = 1
                     NBYTE = INDEX(LASTLINE,'^') - 1
                     IF ((NBYTE.GT.0).AND.(NODRAW.EQ.0))
     +                  CALL IIGTXT(QDSPNO,QOVCH,LASTLINE(1:NBYTE),
     +                              LASTP(1),LASTP(2),0,0,INTEN,0,STAT)
                     LASTLINE(1:) = DLINE(1:)
                     LASTP(1) = NPOS(1)
                     LASTP(2) = NPOS(2)
                  ENDIF
C	  
                  IX(NVAL) = NINT(RBUF(5))
                  IY(NVAL) = NINT(RBUF(6))
               ENDIF
            ENDIF
         ENDIF
40    CONTINUE
C 
      IF (IC.EQ.3) THEN
         IF (NODRAW.EQ.0) THEN
            NBYTE = INDEX(LASTLINE,'^') - 1
            CALL IIGTXT(QDSPNO,QOVCH,LASTLINE(1:NBYTE),
     +                  LASTP(1),LASTP(2),0,0,INTEN,0,STAT)
         ENDIF
      ENDIF
C 
      IF (NVAL.GT.1) THEN
         CALL IIGPLY(QDSPNO,QOVCH,IX,IY,NVAL,INTEN,1,STAT)
      ENDIF
C
C ... end
C
      CALL TBTCLO(TID,STAT)
      CALL DTCLOS(QDSPNO)
C refresh the overlay:      
      CALL REFOVR(STAT) 
      CALL STSEPI
C
C  Formats
9020  FORMAT (I4)
9030  FORMAT (F7.2)
10077 FORMAT('row no.',I5,' contains bad coord(s) - we skip ...')
      END

      SUBROUTINE DRAWME(FLAG,FILL,XY1,XY2,INTENS)
C
C
      IMPLICIT NONE
C 
      INTEGER INTENS,N,NOP,IK,SW,N1,N2,M(2),IX,IY
      INTEGER XFIG(513),YFIG(513)
      INTEGER FLAG,FILL,RADIUS,RADX,RADY,NCX,NCY
      INTEGER CENTER(2)
C
      REAL XY1(2),XY2(2)
      REAL CONST,ANGLE,FACTO,AA
C
      INCLUDE 'MID_INCLUDE:IDIDEV.INC/NOLIST'
      INCLUDE 'MID_INCLUDE:IDIMEM.INC/NOLIST'
C
C  branch according to flag
      GO TO (100,200,100,500,600,700,800,900,1000),FLAG
C
C  construct coordinates for a rectangle
100   IF (FILL.NE.1) THEN
         XFIG(1) = XY1(1)
         YFIG(1) = XY1(2)
         XFIG(2) = XY2(1)
         YFIG(2) = YFIG(1)
         XFIG(3) = XFIG(2)
         YFIG(3) = XY2(2)
         XFIG(4) = XY1(1)
         YFIG(4) = YFIG(3)
         XFIG(5) = XFIG(1)
         YFIG(5) = YFIG(1)
         NOP = 5
      ELSE
         N1 = XY1(2)
         N2 = XY2(2)
         M(1) = XY1(1)
         M(2) = XY2(1)
         IK = 1
         SW = 1
         DO 150, N=N1,N2
            XFIG(IK) = M(SW)
            YFIG(IK) = N
            SW = 3 - SW                         !oscillate between 1 and 2
            IK = IK + 1
            XFIG(IK) = M(SW)
            YFIG(IK) = N
            IK = IK + 1
150      CONTINUE
         NOP = IK - 1
      ENDIF
      GO TO 10000
C
C  construct coordinates of a circle
200   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
      RADX   = ABS(XY1(1)-CENTER(1))
      RADY   = ABS(XY1(2)-CENTER(2))
      RADIUS = NINT((RADX+RADY)*0.5)            !get no. of points to draw
      NOP    = MIN(512,6*RADIUS)
      CONST  = 6.27/NOP
      FACTO = 0.017453                          !Pi / 180.
C
C  construct points on circle
      IF (FILL.NE.1) THEN
         DO 300, N=1,NOP+1
            ANGLE = (N-1)*CONST
            XFIG(N) = CENTER(1) + NINT(RADIUS*COS(ANGLE))
            YFIG(N) = CENTER(2) + NINT(RADIUS*SIN(ANGLE))
300      CONTINUE
         NOP = NOP + 1
      ELSE
         M(1) = CENTER(2) - RADIUS                !low y
         M(2) = CENTER(2) + RADIUS                !high y
         NCX = CENTER(1)
         NCY = CENTER(2)
         XFIG(1) = NCX
         YFIG(1) = M(1)
         IK = 2
         SW = -900                             !start at -90 degs */
         AA = 0.1 * FACTO
         DO 350, N=M(1),M(2)
C 
330         SW = SW + 1
            IF (SW.GT.900) GOTO 355            !avoid infinite loop
            ANGLE = SW * AA
            IY = NINT(RADIUS*SIN(ANGLE))
            N1 = NCY + IY                      !test y-value of circle
            IF (N1.LT.N) GOTO 330
C 
            IX = NINT(RADIUS*COS(ANGLE))
            XFIG(IK) = NCX + IX
            YFIG(IK) = NCY + IY
            IK = IK + 1
            XFIG(IK) = NCX - IX
            YFIG(IK) = YFIG(IK-1)
            IK = IK + 1
            XFIG(IK) = NCX + IX
            YFIG(IK) = YFIG(IK-1)
            IK = IK + 1
350      CONTINUE
355      XFIG(IK) = NCX
         YFIG(IK) = M(2)
         NOP = IK 
      ENDIF
      GOTO 10000
C
C  construct coordinates of a triangle
500   IF (FILL.NE.1) THEN
         XFIG(1) = XY1(1)
         YFIG(1) = XY1(2)
         CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
         XFIG(2) = CENTER(1)
         YFIG(2) = XY2(2)
         XFIG(3) = XY2(1)
         YFIG(3) = XY1(2)
         XFIG(4) = XY1(1)
         YFIG(4) = XY1(2)
         NOP = 4
      ENDIF
      GO TO 10000
C
C  construct coordinates of a triangle
600   XFIG(1) = XY1(1)
      YFIG(1) = XY2(2)
      CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
      XFIG(2) = CENTER(1)
      YFIG(2) = XY1(2)
      XFIG(3) = XY2(1)
      YFIG(3) = XY2(2)
      XFIG(4) = XY1(1)
      YFIG(4) = XY2(2)
      NOP = 4
      GOTO 10000
C
C  construct coordinates of a cross
700   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
      XFIG(1) = XY1(1)
      YFIG(1) = CENTER(2)
      XFIG(2) = XY2(1)
      YFIG(2) = YFIG(1)
      XFIG(3) = CENTER(1)
      YFIG(3) = YFIG(2)
      XFIG(4) = XFIG(3)
      YFIG(4) = XY2(2)
      XFIG(5) = XFIG(4)
      YFIG(5) = XY1(2)
      NOP = 5
      GOTO 10000
C
C  construct coordinates of an open cross
800   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
      IK = (XY2(1) - CENTER(1))/2
      IF (IK.LT.1) IK = 1
C 
      XFIG(1) = XY1(1)
      YFIG(1) = CENTER(2)
      XFIG(2) = CENTER(1) - IK
      YFIG(2) = YFIG(1)
      NOP = 2
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      XFIG(1) = CENTER(1) + IK
      XFIG(2) = XY2(1)
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      XFIG(1) = CENTER(1)
      YFIG(1) = XY1(2)
      XFIG(2) = XFIG(1)
      YFIG(2) = CENTER(2) - IK
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      YFIG(1) = CENTER(2) + IK
      YFIG(2) = XY2(2)
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      RETURN
C
C  construct coordinates of a diamond
900   CENTER(1) = NINT((XY1(1)+XY2(1))*0.5)
      CENTER(2) = NINT((XY1(2)+XY2(2))*0.5)
      XFIG(1) = CENTER(1)
      YFIG(1) = XY1(2)
      XFIG(2) = XY2(1)
      YFIG(2) = CENTER(2)
      XFIG(3) = XFIG(1)
      YFIG(3) = XY2(2)
      XFIG(4) = XY1(1)
      YFIG(4) = YFIG(2)
      XFIG(5) = XFIG(1)
      YFIG(5) = YFIG(1)
      NOP = 5
      GOTO 10000
C
C  construct coordinates of an X shaped cross
1000  XFIG(1) = XY1(1)
      YFIG(1) = XY1(2)
      XFIG(2) = XY2(1)
      YFIG(2) = XY2(2)
      NOP = 2
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      YFIG(1) = XY2(2)
      XFIG(2) = XY2(1)
      YFIG(2) = XY1(2)
      CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
      RETURN
C
C  now draw the shape
10000 CALL IIGPLY(QDSPNO,QOVCH,XFIG,YFIG,NOP,INTENS,1,N)
C
      RETURN
      END