C===========================================================================
C Copyright (C) 1995-2010 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
C+++++++++++++++++++++++++++++++++++++++++++++++++++
C 
C.IDENTIFICATION: OVERIDEN 
C.PURPOSE:   Draw columns of a table on a graphic screen
C.           in overlay mode (after a plot command)
C.AUTHOR:    J.D.Ponz       ESP - Garching
C.KEYWORDS:  Identification, table, overlay
C.USE:       OVERPLOT/IDEN table col-ref1 col-ref2 [UP/DOWN]
C.ALGORITHM: Use the routines of the agl library
C.LANGUAGE:  F77+ESOext
C.VERSION:   1.0  820707
C.VERSION:   2.0  821115
C.VERSION:   2.1  840227
C.VERSION:   3.0  860624  Conversion to Fortran 77 + ESO extensions
C 
C 190323	last modif	use STTPUT for output all over  KB
C-----------------------------------------------------------------------------
      PROGRAM   OVRIDN
      IMPLICIT  NONE
C
      INTEGER   MADRID,TID
      INTEGER   NPAR,ISTAT,ILEN,ILAB
      INTEGER   I,IAC
      INTEGER   NCOLUM,NCOL,NROW,NSC
      INTEGER   NLIM,NLAB
      INTEGER   COL(4),NTOT
      INTEGER   PARNEV,NVAL(1000)
      INTEGER   DTYPE,NACOL,NAROW

      INTEGER   ACCESS, PLMODE
      REAL      SIZEX,SIZEY,Y,Y2,Y3,VX
      REAL      YDUM
      REAL      XD(3), YD(3), CLIP(4)
C     REAL      RIDENT
      DOUBLE PRECISION DIDENT
      REAL      X(1000),XL(1000),XR(1000)
      REAL      WIND(8),XPS(2),YPS(2)

      LOGICAL   IWIND,NULL,ISEL,IMESH

      CHARACTER TABLE*64,IUD*1
      CHARACTER AFORM*8,IDENT*20,CTEST*20,FORM*16
      CHARACTER*17 COLUMN(4)
      CHARACTER TEXT*80
 
      INCLUDE   'MID_INCLUDE:PLTDEC.INC/NOLIST'
      INCLUDE   'MID_INCLUDE:TABLES.INC/NOLIST'
      COMMON    /VMR/MADRID(1)

      INCLUDE   'MID_INCLUDE:TABLED.INC/NOLIST'
      DATA      NTOT/1000/
      DATA      PARNEV/5/
C
C9000 FORMAT (I4)
 9011 FORMAT('SYDI=',F6.2)
 9012 FORMAT('CHDI=',F6.2,',',F6.2)
C
      CALL STSPRO('OVERIDEN')
C
      CALL TDPGET(PARNEV,NPAR,ISTAT)
      IF (ISTAT.NE.0) THEN
         TEXT = '*** FATAL: Problems with table parameters '
         CALL STTPUT(TEXT,ISTAT)
         CALL STSEPI
      ENDIF

      TABLE     = TPARBF(1)
      COLUMN(1) = TPARBF(2)
      COLUMN(2) = TPARBF(3)
      IUD       = TPARBF(4)
      NCOLUM    = 2
      IMESH     = .TRUE.
C
C ... read table
      CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT)
      IF (ISTAT.NE.0) THEN
         TEXT = '*** FATAL: Failed to open table: '//TABLE
         CALL STTPUT(TEXT,ISTAT)
         CALL STSEPI
      ENDIF
C
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,ISTAT)
      IF (ISTAT.NE.0) THEN
         TEXT = '*** FATAL: Failed to get table info '//TABLE
         CALL STTPUT(TEXT,ISTAT)
         CALL STSEPI
      ENDIF
C
C ... get column addresses
      DO 10 I = 1,NCOLUM
          CALL TBCSER(TID,COLUMN(I),COL(I),ISTAT)
          IF (ISTAT.NE.0) THEN
             TEXT = '*** FATAL: Failed to get table column'
             CALL STTPUT(TEXT,ISTAT)
             CALL STSEPI
          ENDIF

          IF (COL(I).EQ.-1) THEN
             TEXT = '*** FATAL: Failed to get table column'
             CALL STTPUT(TEXT,ISTAT)
             CALL STSEPI
          ENDIF
   10 CONTINUE
C
      CALL TBFGET(TID,COL(2),AFORM,ILEN,DTYPE,ISTAT)
      I      = INDEX(AFORM,' ')-1
      FORM   = '('//AFORM(1:I)//')'
C
C ... plot - AGL window
      ACCESS = 1
      PLMODE = -1
      CALL PTOPEN(' ',' ',ACCESS,PLMODE)
      CALL AGSSET('BOTT')
      CALL PTKRDR('XWNDL',4,IAC,WIND)
      CALL PTKRDR('YWNDL',4,IAC,WIND(5))
C
C *** get the character and symbol sizes
      CALL PTKRDR('SSIZE',1,IAC,SSIZE)
      CALL PTKRDR('TSIZE',1,IAC,TSIZE)
      WRITE(TEXT,9011) 0.75*SSIZE
      CALL AGSSET(TEXT)
      WRITE(TEXT,9012) 0.75*TSIZE,0.75*TSIZE
      CALL AGSSET(TEXT)
      LTYPE = 1
C
      SIZEX = ABS(WIND(2)-WIND(1))/60.
      NLIM  = MIN(NINT(ABS(WIND(2)-WIND(1))/SIZEX),NTOT)
      CALL AGRGET('CLPL',CLIP)
      Y2    = (CLIP(4)-CLIP(3))/10.
      CALL AGTGET('M',XD,YD)
      Y3   = YD(2)
      SIZEY = (ILEN+1)*YD(2)
      CALL UPCAS(IUD,IUD)
      IF (IUD.EQ.'T') THEN
         Y = CLIP(4) - Y3
      ELSE
         Y = CLIP(3) + Y3
      END IF
C
C ... first iteration to find label positions
CC      write(*,123)nrow,wind(1),wind(2)
      WRITE(TEXT,123) NROW,WIND(1),WIND(2)
      CALL STTPUT(TEXT,ISTAT)
123   format('nrow = ',i3,' wind(1,2) = ',g15.7,g15.7)
      NLAB  = 0
      DO 20 I = 1,NROW
         CALL TBSGET(TID,I,ISEL,ISTAT)
         IF (ISEL) THEN
            CALL TBERDR(TID,I,COL(1),VX,NULL,ISTAT)
            WRITE(TEXT,1234) I,VX
            CALL STTPUT(TEXT,ISTAT)
CC          write(*,1234) i,vx
1234  format('for selected row ',i4,' vx = ',g15.7)

            IWIND = VX .GE. WIND(1) .AND. VX .LE. WIND(2)
            IF (.NOT.NULL .AND. NLAB.LT.NLIM .AND. IWIND) THEN
               NLAB    = NLAB + 1
               X(NLAB) = VX
            END IF
         END IF
   20 CONTINUE
C
C ... if no label position found, init first XL, XR values here
C     otherwise that's not done inside LBLOVE !!
C 
      IF (NLAB.LT.2) THEN
         XL(1) = 0.0
         XL(2) = 0.0
         XL(3) = 0.0
         XR(1) = 0.0
         XR(2) = 0.0
         XR(3) = 0.0
      ENDIF
C
C ... compute new label positions without overlap
      CALL LBLOVE(X,NLAB,WIND(1),WIND(2),SIZEX,X,NVAL,XL,XR)
C 
C *** het the maximum string length
C ... second iteration to plot labels
      CALL AGSSET('NORM')
      ILAB = 0
      DO 40 I = 1,NROW
         CALL TBSGET(TID,I,ISEL,ISTAT)
         IF (ISEL) THEN
            CALL TBERDR(TID,I,COL(1),VX,NULL,ISTAT)
            IWIND = VX .GE. WIND(1) .AND. VX .LE. WIND(2)
            IF (.NOT. NULL .AND. IWIND) THEN
               IF (DTYPE.NE.D_C_FORMAT) THEN
C                 CALL TBERDR(TID,I,COL(2),RIDENT,NULL,ISTAT)
                  CALL TBERDD(TID,I,COL(2),DIDENT,NULL,ISTAT)
                  IF (.NOT. NULL) THEN
C                    WRITE (IDENT,FORM,ERR=30) RIDENT
                     WRITE (IDENT,FORM,ERR=30) DIDENT
                  END IF
   30             CONTINUE

               ELSE
                  CALL TBERDC(TID,I,COL(2),CTEST,NULL,ISTAT)
                  CALL FT_EOS(CTEST,20,IDENT,ISTAT)
               END IF
               

               ILAB   = ILAB + 1
               IF (ILAB.GE.NLIM) THEN
                  ILAB   = NLIM
                  IF (IMESH) THEN
                     IMESH  = .FALSE.
                     CALL STTPUT(' Warning: Too many identifications',
     +                             ISTAT)
                     CALL STTPUT(
     +             ' Change plotting scale or use SELECT/TABLE',ISTAT)
                  END IF
               END IF

               IF (IUD.EQ.'T') THEN
                  CALL AGVU2N(VX,WIND(6),XPS(1),YDUM)
                  XPS(2) = XPS(1)
                  YPS(1) = Y-SIZEY-Y2-Y3
                  YPS(2) = Y-SIZEY-2*Y2-Y3
                  CALL AGGPLL(XPS,YPS,2)
C
                  IF (IMESH) THEN
                     CALL AGVU2N(X(ILAB),WIND(6),XPS(1),YDUM)
                     CALL AGVU2N(VX,WIND(6),XPS(2),YDUM)
                     YPS(1) = Y-SIZEY-Y3
                     YPS(2) = Y-SIZEY-Y2-Y3
                     CALL PTDATA(0,1,0,XPS,YPS,0.0,2)
                     CALL AGGTXT(XPS(1),Y,IDENT(1:ILEN),4)
                  END IF

               ELSE
                  CALL AGVU2N(VX,WIND(5),XPS(1),YDUM)
                  XPS(2) = XPS(1)
                  YPS(1) = Y+SIZEY+Y2+Y3
                  YPS(2) = Y+SIZEY+2*Y2+Y3
                  CALL PTDATA(0,1,0,XPS,YPS,0.0,2)

                  IF (IMESH) THEN
                     CALL AGVU2N(X(ILAB),WIND(5),XPS(1),YDUM)
                     CALL AGVU2N(VX,WIND(5),XPS(2),YDUM)
                     YPS(1) = Y+SIZEY+Y3
                     YPS(2) = Y+SIZEY+Y2+Y3
                     CALL PTDATA(0,1,0,XPS,YPS,0.0,2)
                     CALL AGGTXT(XPS(1),Y,IDENT(1:ILEN),8)
                  ENDIF

               END IF
               IDENT  = ' '
            END IF
         END IF
   40 CONTINUE
C
C ... end
      CALL TBTCLO(TID,ISTAT)
      CALL PTCLOS()
      CALL STSEPI
      END



      SUBROUTINE LBLOVE(X,N,XLEFT,XRIGHT,DELTA,XC,NVAL,XL,XR)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: LBLOVE
C.PURPOSE:        Compute new label positions without overlapping
C--------------------------------------------------------------------------
      IMPLICIT NONE	
      INTEGER  N                                           ! dimension of X
      REAL     X(N)                                        ! original positions
      REAL     XLEFT                                       ! left boundary
      REAL     XRIGHT                                      ! right boundary
      REAL     DELTA                                       ! size of label
      REAL     XC(N)
      INTEGER  NVAL(N)
      REAL     XL(N)                                       ! new positions
      REAL     XR(N)  
  
      REAL     D, D2
      REAL     XAVE
      INTEGER  I, J, J1, K
      INTEGER  M, L, ISTAT 
C 
      CHARACTER TEXT*80
C
      LOGICAL IOVER
C
C ... assign initial values
C
      D2     = DELTA/2.
CC      write(*,1234) d2,n
      WRITE(TEXT,1234) D2,N
      CALL STTPUT(TEXT,ISTAT)
1234  format('d2 = ',g15.7,' n = ',i3)
CC      write(*,123) 'X:',x(1),x(2)
      WRITE(TEXT,123) 'X:',X(1),X(2)
      CALL STTPUT(TEXT,ISTAT)
      DO 10 I = 1,N
         XL(I)  = MAX(X(I)-D2,XLEFT)
         XR(I)  = MIN(X(I)+D2,XRIGHT)
         NVAL(I) = 1
         IF (XL(I).EQ.XLEFT) THEN
            XR(I)  = XL(I) + DELTA
         ENDIF
         IF (XR(I).EQ.XRIGHT) THEN
            XL(I)  = XR(I) - DELTA
         ENDIF
   10 CONTINUE

CC      write(*,123) 'XL:',xl(1),xl(2)
      WRITE(TEXT,123) 'XL:',XL(1),XL(2)
      CALL STTPUT(TEXT,ISTAT)
123   format(' ',a,g15.7,g15.7)
CC      write(*,123) 'XR:',xr(1),xr(2)
      WRITE(TEXT,123) 'XR:',XR(1),XR(2)
      CALL STTPUT(TEXT,ISTAT)
C
C ... merge labels
C
      M      = N
C
   20 CONTINUE
      IOVER  = .FALSE.
      I      = 2
C
   30 CONTINUE
      IF (XR(I-1).GT.XL(I)) THEN
         NVAL(I-1) = NVAL(I-1) + NVAL(I)
         L      = 0
         DO 50 J = 1,M
            IF (J.NE.I) THEN
               J1     = J
               IF (J.GT.I) J1     = J1 - 1
               XAVE   = 0.D0
               DO 40 K = 1,NVAL(J)
                  L      = L + 1
                  XAVE   = XAVE + X(L)
   40          CONTINUE
               XAVE   = XAVE/FLOAT(NVAL(J))
               D      = DELTA*FLOAT(NVAL(J))
               XL(J1) = MAX(XAVE-D/2.,XLEFT)
               XR(J1) = MIN(XAVE+D/2.,XRIGHT)
               NVAL(J1) = NVAL(J)
               IF (XL(J1).EQ.XLEFT) XR(J1) = XL(J1) + D
               IF (XR(J1).EQ.XRIGHT) XL(J1) = XR(J1) - D
            END IF
   50    CONTINUE
         IF (M.EQ.1) THEN
            GOTO 60
         ELSE
            M = M - 1
         ENDIF
         IOVER  = .TRUE.
      END IF
C
      I      = I + 1
      IF (M.EQ.1) GO TO 60
      IF (I.LE.M) GO TO 30
      IF (IOVER) GO TO 20
C
C ... assign final values
C
   60 L      = 0
      DO 80 I = 1,M
         DO 70 J = 1,NVAL(I)
            L      = L + 1
            XC(L)  = XL(I) + (J-1)*DELTA + D2
   70    CONTINUE
   80 CONTINUE
C
      RETURN
      END

