C  @(#)tdcmph.for	19.1 (ESO-IPG) 02/25/03 14:11:15 
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
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION:
C       TDCMPH.FOR
C
C.KEYWORDS
C       histogram, tables, images
C
C.PURPOSE
C
C  execute the command
C
C  COMP/HIST OUTPUT = TABLE COLUMN-REF [STEP [MIN-VAL  [MAX-VAL]]]
C        --------or---------
C  COMP/HIST OUTPUT = IMAGE [START1,START2:END1,END2] [step min max]
C
C  WHERE 'OUTPUT' CAN BE EITHER 'frame' OR 'name/TABLE'
C
C.ALGORITHM
C
C  USE TABLE INTERFACE ROUTINES
C 
C 020807		last modif
C 
C-----------------------------------------------------------
C
      SUBROUTINE TDCMPH
      IMPLICIT NONE
C
C ... PARAMETER DEFINITION
C
      INTEGER       MADRID
      INTEGER       NEVALS
      INTEGER       TID, TID1, II1, II2, IDUMMY, NVALS
      INTEGER       STATUS, ISTAT, ICOL
      INTEGER       NROW, OTAB, IX, NNN
      INTEGER       NCOL, NSC, NAC, NAR
      INTEGER       NPAR, DUMMY, II, LEN
      INTEGER*8     IPTR, ADDR1, OPNTR
      INTEGER       NBINS, IC1, IC2
      INTEGER       INDEX, NPIX(3), SUBDIM, SUBLO(3), SUBHI(3)
      INTEGER       TYPE, RESPIX(4), TINULL
      INTEGER       NAXIS, IMNO, IVAL(4),TLEN,LLEN
C
      LOGICAL       ITAB
C
      REAL X0,X1,XT,AXMAX,AXMIN,START, CUTVLS(4), OUTPR(4)
      REAL XMIN,XMAX,RPAR(3),STEP,LHCUTS(4), TRNULL
C
      DOUBLE PRECISION DSTART, DSTEP, START1(3), STEP1(3), TDNULL
C
      CHARACTER*16  LABEL, UNIT
      CHARACTER*8   FORM
      CHARACTER     COLREF*17,WORK*60
      CHARACTER     CUNIT*72
      CHARACTER*80  DUNIT, CIDEN, TABLE, FRAME
      CHARACTER*16  MSG
C
      INCLUDE   'MID_INCLUDE:TABLES.INC'
      COMMON /VMR/MADRID(1)
      INCLUDE   'MID_INCLUDE:TABLED.INC'
C
      DATA      NEVALS/7/
      DATA      MSG/'ERR:TCOMPHSTxxxx'/
      DATA      NPIX /1,1,1/
      DATA      START1 /0.,0.,0./, STEP1 /1.,1.,1./
C
C ... GET INPUT PARAMETERS + DEFAULT
C
      CALL TDPGET(NEVALS,NPAR,ISTAT)
      IF (ISTAT.NE.0) GO TO 30
      TABLE   = TPARBF(3)
      CALL GENLEN(TABLE,TLEN)
      COLREF  = TPARBF(4)
      IF (COLREF(1:1).EQ.':' .OR. COLREF(1:1).EQ.'#') THEN
         ITAB = .TRUE.
      ELSE
         ITAB = .FALSE.
      ENDIF
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
      RPAR(2) = TRNULL
      RPAR(3) = RPAR(2)
      RPAR(1) = 0.0
      II1     = 1
      DO 20 II2 = 5,NPAR
          II     = INDEX(TPARBF(II2),' ') - 1
          WORK   = TPARBF(II2) (1:II)
          CALL GENCNV(WORK,2,1,IDUMMY,RPAR(II1),DUMMY,NVALS)
          II1    = II1 + 1
          IF (NVALS.NE.1) GO TO 30
   20 CONTINUE
      STEP   = RPAR(1)
      AXMIN  = RPAR(2)
      AXMAX  = RPAR(3)
C
C ... READ INPUT DATA SET
C
C                                                 TABLE INPUT DATA
      IF (ITAB) THEN
        TID = -1
        CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT)
        IF (ISTAT.NE.0) GO TO 30
        CALL TBIGET(TID,NCOL,NROW,NSC,NAC,NAR,ISTAT)
        IF (ISTAT.NE.0) GO TO 30
C
C ... FIND INPUT COLUMN
C
        ICOL   = -1
        CALL TBCSER(TID,COLREF,ICOL,ISTAT)
        IF (ICOL.EQ.-1) THEN
            CALL STTPUT('Column not found...',ISTAT)
            GO TO 30
        END IF
        CALL TBLGET(TID,ICOL,LABEL,ISTAT)
        CALL GENLEN(LABEL,LLEN)
        CALL TBUGET(TID,ICOL,UNIT,ISTAT)
        CALL TBFGET(TID,ICOL,FORM,LEN,TYPE,ISTAT)
        IF (TYPE.EQ.D_C_FORMAT) THEN
            CALL STTPUT('Error, Column of type Character',ISTAT)
          GO TO 30
        END IF
C
C ... BUILD THE GRID
C
        IF (AXMIN.EQ.TRNULL .OR. AXMAX.EQ.TRNULL) THEN
            CALL TDUMNX(TID,ICOL,NROW,0,XMIN,XMAX)
            CALL TDSCAL(XMIN,XMAX,1.,X0,X1,IX,XT,NNN)
            IF (AXMIN.EQ.TRNULL) AXMIN  = X0*10.**IX
            IF (AXMAX.EQ.TRNULL) AXMAX  = X1*10.**IX
        ENDIF
        IF (STEP.EQ.0.0) THEN
            CALL TDSCAL(AXMIN,AXMAX,1.,X0,X1,IX,XT,NNN)
            STEP   = XT
        END IF
        NBINS  = (AXMAX-AXMIN)/STEP
        START  = AXMIN + STEP*0.5
      ELSE
C                                                          IMAGE INPUT DATA
        CALL STIGET(TABLE,D_R4_FORMAT,F_I_MODE,F_IMA_TYPE,
     .  3,NAXIS,NPIX,START1,STEP1,CIDEN,CUNIT,IPTR,IMNO,ISTAT)
        IF (ISTAT.NE.0) GO TO 30
C
C ... GET SUBIMAGE SPECIFICATION
C
        IF (COLREF(1:1) .EQ. '[') THEN
           CALL EXTCOO(IMNO,COLREF,3,SUBDIM,SUBLO,SUBHI,ISTAT)
        ELSE
           SUBDIM   = NAXIS
           SUBLO(1) = 1
           SUBLO(2) = 1
           SUBLO(3) = 1
           SUBHI(1) = NPIX(1)
           SUBHI(2) = NPIX(2)
           SUBHI(3) = NPIX(3)
        ENDIF
C
C ... BUILD THE GRID
C
        IF (AXMIN.EQ.TRNULL .OR. AXMAX.EQ.TRNULL) THEN
            CALL STVALS('MIN',MADRID(IPTR),SUBDIM,NPIX,
     .      SUBLO,SUBHI,CUTVLS,OUTPR,RESPIX,IVAL,ISTAT)
            XMIN = OUTPR(1)
            XMAX = OUTPR(2)
            CALL TDSCAL(XMIN,XMAX,1.,X0,X1,IX,XT,NNN)
            IF (AXMIN.EQ.TRNULL) AXMIN  = X0*10.**IX
            IF (AXMAX.EQ.TRNULL) AXMAX  = X1*10.**IX
        ENDIF
        IF (STEP.EQ.0.0) THEN
            CALL TDSCAL(AXMIN,AXMAX,1.,X0,X1,IX,XT,NNN)
            STEP   = XT
        END IF
        NBINS  = (AXMAX-AXMIN)/STEP
        START  = AXMIN + STEP*0.5
      ENDIF
C
C ... CREATE OUTPUT TABLE OR FRAME
C
      OTAB   = INDEX(TPARBF(1),'/T')
      IF (OTAB.EQ.0) OTAB   = INDEX(TPARBF(1),'/t')
      IF (OTAB.EQ.0) THEN
          FRAME  = TPARBF(1)
          WORK   = ' HISTOGRAM TABLE '//TABLE(1:TLEN)//
     1             ' .COLUMN '//LABEL(1:LLEN)
          CUNIT  = 'FREQUENCY       '//UNIT
          DSTART = AXMIN
          DSTEP  = STEP
          CALL STIPUT(FRAME,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,
     .    1,NBINS,DSTART,DSTEP,WORK,CUNIT,OPNTR,TID1,ISTAT)
      ELSE
          FRAME  = TPARBF(1) (1:OTAB-1)
          NVALS  = 4
          CALL TBTINI(FRAME,F_TRANS,F_O_MODE,NVALS,NBINS,TID1,ISTAT)
          CALL TBCINI(TID1,D_R4_FORMAT,1,FORM,UNIT,LABEL,IC1,ISTAT)
          UNIT   = ' '
          LABEL  = 'FREQUENCY'
          CALL TBCINI(TID1,D_R4_FORMAT,1,FORM,UNIT,LABEL,IC2,ISTAT)
          CALL TBCMAP(TID1,IC1,ADDR1,ISTAT)
          CALL TBCMAP(TID1,IC2,OPNTR,ISTAT)
          CALL SAMPLE(NBINS,MADRID(ADDR1),START,STEP)
          CALL TBIPUT(TID1,0,NBINS,ISTAT)
      END IF
C
C ... FREQUENCY ANALYSIS
C
      IF (ITAB) THEN
          CALL TDHSTM(TID,ICOL,NROW,NBINS,MADRID(OPNTR),
     .    AXMIN,STEP,LHCUTS(3),LHCUTS(4))
          CALL TBTCLO(TID,ISTAT)
      ELSE
          CUTVLS(1) = AXMIN
          CUTVLS(2) = CUTVLS(1)
          CALL TDIHST(MADRID(IPTR),SUBDIM,NPIX,SUBLO,SUBHI,CUTVLS,
     .    STEP,NBINS,MADRID(OPNTR),LHCUTS(3),LHCUTS(4))
      END IF
C
C ... END
C
      CALL TDHSTR(TID1,ISTAT)
      IF (OTAB.NE.0) THEN
          CALL TBSINI(TID1,ISTAT)
          CALL DSCUPT(TID1,TID1,' ',ISTAT)
          CALL TBTCLO(TID1,ISTAT)
      ELSE
          CALL STDWRR(TID1,'LHCUTS',LHCUTS,1,4,DUNIT,ISTAT)
      END IF
   30 IF (ISTAT.NE.0) THEN
          WRITE (MSG(13:16),9000) ISTAT
          CALL TDERRR(ISTAT,MSG,STATUS)
      END IF
      RETURN
 9000 FORMAT (I4)
      END

      SUBROUTINE SAMPLE(N,X,X0,XS)
C
C GENERATES SAMPLING STEPS IN THE ARRAY X AS
C X(I) = X0 + (I-1)*XS
C
      IMPLICIT NONE
      INTEGER N
      REAL    X(N)
      REAL    X0, XS
      INTEGER I
C
      DO 10 I = 1,N
          X(I)   = X0 + (I-1)*XS
   10 CONTINUE
      RETURN
      END

