C @(#)overiden.for 17.1.1.1 (ES0-DMD) 01/25/02 17:56:14 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, C all rights reserved 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----------------------------------------------------------------------------- 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,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 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) 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 ... 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),IDENT,NULL,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 C LOGICAL IOVER C C ... assign initial values C D2 = DELTA/2. 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 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