C @(#)tdrhist.for	17.1.1.1 (ES0-DMD) 01/25/02 17:47:16
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
C.VERSION: 1.1  ESO-FORTRAN Conversion, AA  15:21 - 19 NOV 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION:
C     TDRHIST
C
C.PURPOSE
C
C  Execute the command
C   READ/HISTO table-name column-ref1
C   PRINT/HISTO table-name column-ref1
C
C.KEYWORDS
C
C  Histogram, tables
C
C.ALGORITHM
C
C  uses table interface routines
C
C MODIFS              M Peron 081090
C-----------------------------------------------------------
C
      SUBROUTINE TDRHIS
      IMPLICIT NONE
C
      INTEGER      CODE, ISTAT, NPAR, TID, IAC
      INTEGER      NBINS, NCOL, NROW, NSC, NAC, NAR
      INTEGER      STATUS, INS
      INTEGER      COL(3)
      INTEGER      PNEVAL, DUNIT, DNULL
      INTEGER      PNCODE
      INTEGER      IFR(512)
C
      REAL         TSTAT(8),CL(512)
C
      CHARACTER*80 TABLE
      CHARACTER*16 OLAB
      CHARACTER*22 LABEL1,LABEL2
      CHARACTER*30 LAB
      CHARACTER*80 LINE
      CHARACTER*80 LINE1
      CHARACTER*16 LABEL(3),UNIT(3)
      CHARACTER*10 DESNA1, DESNA2, DESNA3
      CHARACTER*4  WS
      CHARACTER*2  PCODE
      CHARACTER*16 MSG
      CHARACTER*30 COLUMN(3)
C
       INCLUDE 'MID_INCLUDE:TABLES.INC'
       INCLUDE 'MID_INCLUDE:TABLED.INC'
C
      DATA PNCODE/2/
      DATA PNEVAL/5/
      DATA PCODE/'PR'/
      DATA DESNA1/'TSTATxxx  '/
      DATA DESNA2/'TCLASxxx  '/
      DATA DESNA3/'TFREQxxx  '/
      DATA MSG/'ERR:THISTTBLxxxx'/
C
C ... get input parameters + default
C
      CALL TDPCOD(PNCODE,PCODE,CODE,ISTAT)
      CALL TDPGET(PNEVAL,NPAR,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      TABLE  = TPARBF(1)
      COLUMN(1) = TPARBF(2)
C
C ... read table (only descriptors)
C
      CALL TBTOPN(TABLE,F_D_MODE,TID,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      CALL TBCSER(TID,COLUMN(1),COL(1),ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      IF (COL(1).EQ.-1) THEN
          ISTAT  = ERRPAR
          GO TO 10
      END IF
      CALL TBLGET(TID,COL(1),LABEL(1),ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      CALL TBUGET(TID,COL(1),UNIT(1),ISTAT)
      IF (ISTAT.NE.0) GO TO 10
C
C ... Display histogram
C
      LAB    = 'HISTOGRAM TABLE : '//TABLE
      LABEL1 = 'FREQUENCY'
      OLAB   = 'COLUMN '
      IF (LABEL(1) (1:2).EQ.'  ') THEN
          WRITE (OLAB(7:10),9000) COL(1)
      ELSE
          OLAB   = LABEL(1)
      END IF
      LABEL2 = 'BINS: '//OLAB
      INS    = COL(1) + 1000
      WRITE (WS,9000) INS
      DESNA1(6:8) = WS(2:4)
      DESNA2(6:8) = WS(2:4)
      DESNA3(6:8) = WS(2:4)
      CALL STDRDR(TID,DESNA1,1,8,IAC,TSTAT,DUNIT,DNULL,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      NBINS  = TSTAT(7)
      CALL STDRDR(TID,DESNA2,1,NBINS,IAC,CL,DUNIT,DNULL,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
      CALL STDRDI(TID,DESNA3,1,NBINS,IAC,IFR,DUNIT,DNULL,ISTAT)
      IF (ISTAT.NE.0) GO TO 10
C
C  delete descriptors
C
      CALL STDDEL(TID,DESNA1,ISTAT)
      CALL STDDEL(TID,DESNA2,ISTAT)
      CALL STDDEL(TID,DESNA3,ISTAT)
C
      LINE   = '  TABLE :         '
      LINE(11:) = TABLE(1:)
      CALL STTPUT(LINE,ISTAT)
      CALL TDRSEL(TID,LINE,ISTAT)
      IF (LINE(1:1).NE.'-') THEN
          LINE1  = ' SELECT  '//LINE
          CALL STTPUT(LINE1,ISTAT)
      END IF
      CALL TDHLIS(NBINS,CL,IFR,TSTAT,LABEL1,LABEL2,LAB,UNIT(1),ISTAT)
      IF (ISTAT.NE.0) GO TO 10
C
C ... end
C
      CALL TBTCLO(TID,ISTAT)
   10 IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
          CALL TDERRR(ISTAT,MSG,STATUS)
      END IF
      RETURN
 9000 FORMAT (I4)
      END