C @(#)tdfreq.for	17.1.1.1 (ESO-DMD) 01/25/02 17:47: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 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.1  ESO-FORTRAN Conversion, AA  14:13 - 19 NOV 1987
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION:
C               TDFREQ.FOR
C
C.KEYWORDS
C    HISTOGRAM, TABLES
C
C.PURPOSE
C
C  EXECUTE THE COMMAND
C  COMP/HIST OUTPUT = TABLE COLUMN-REF [STEP [MIN-VAL  [MAX-VAL]]]
C  WHERE 'OUTPUT' CAN BE EITHER 'frame' OR 'name/TABLE'
C
C.ALGORITHM
C
C  USE TABLE INTERFACE ROUTINES
C
C-----------------------------------------------------------
C

      SUBROUTINE RFREQU(NROW,X,M,NPIX,F,START,STEP,RMIN,RMAX)
C
C COMPUTE THE FREQUENCY
C SINGLE PRECISION VERSION
C
      IMPLICIT NONE
      INTEGER  NROW, NPIX
      REAL X(NROW),M(NROW),F(NPIX)
      REAL START, STEP, RMIN, RMAX
C
      INTEGER  I, J
C 
      INTEGER TINULL
      REAL    TRNULL, TBLSEL
      DOUBLE PRECISION TDNULL, TDTRUE, TDFALS
C
C ... GET MACHINE CONSTANTS
C
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
C
C
      DO 10 I = 1,NPIX
          F(I)   = 0.
   10 CONTINUE
      RMIN   = 0.
      RMAX   = 0.
      DO 20 I = 1,NROW
          IF (M(I).EQ.TBLSEL .AND. X(I).NE.TRNULL) THEN
              J      = (X(I)-START)/STEP + 1
              IF (J.GE.1 .AND. J.LE.NPIX) THEN
                  F(J)   = F(J) + 1
                  RMAX   = AMAX1(RMAX,F(J))
              END IF
          END IF
   20 CONTINUE
      RETURN
      END

      SUBROUTINE DFREQU(NROW,X,M,NPIX,F,START,STEP,RMIN,RMAX)
C
C COMPUTE THE FREQUENCY
C DOUBLE PRECISION VERSION
C
      IMPLICIT NONE
      INTEGER          NROW, NPIX
      REAL             M(NROW),F(NPIX)
      DOUBLE PRECISION X(NROW)
      REAL             START, STEP, RMIN, RMAX
C
      INTEGER          I, J
C 
      INTEGER TINULL
      REAL    TRNULL, TBLSEL
      DOUBLE PRECISION TDNULL, TDTRUE, TDFALS
C
C ... GET MACHINE CONSTANTS
C
      CALL TBMNUL(TINULL, TRNULL, TDNULL)
      CALL TBMCON(TBLSEL, TDTRUE, TDFALS)
C
C
      DO 10 I = 1,NPIX
          F(I)   = 0.
   10 CONTINUE
      RMIN   = 0.
      RMAX   = 0.
      DO 20 I = 1,NROW
          IF (M(I).EQ.TBLSEL .AND. X(I).NE.TDNULL) THEN
              J      = (X(I)-START)/STEP + 1
              IF (J.GE.1 .AND. J.LE.NPIX) THEN
                  F(J)   = F(J) + 1
                  RMAX   = AMAX1(RMAX,F(J))
              END IF
          END IF
   20 CONTINUE
      RETURN
      END

      SUBROUTINE TDHSTM(TID,ICOL,NROW,NPIX,F,START,STEP,RMIN,RMAX)
C
C COMPUTE HISTOGRAM FOR A TABLE COLUMN
C
      IMPLICIT NONE
      INTEGER  TID, ICOL, NROW, NPIX
      REAL     F(NPIX)
      REAL     START, STEP, RMIN, RMAX, XX
C
      LOGICAL  ISEL, NULL
      INTEGER  I, J, STATUS
C 
      DO 10 I = 1, NPIX
          F(I)   = 0.
   10 CONTINUE
      RMIN   = 0.
      RMAX   = 0.
      DO 20 I = 1,NROW
          CALL TBSGET(TID, I, ISEL, STATUS)
          IF (ISEL) THEN
             CALL TBERDR(TID, I, ICOL, XX, NULL, STATUS)
             IF (.NOT.NULL) THEN
                  J      = (XX-START)/STEP + 1
                  IF (J.GE.1 .AND. J.LE.NPIX) THEN
                      F(J)   = F(J) + 1
                      RMAX   = AMAX1(RMAX,F(J))
                  ENDIF
             ENDIF
          ENDIF
   20 CONTINUE
      RETURN
      END


      SUBROUTINE
     .TDIHST(ARRAY,NAXIS,NPIX,SUBLO,SUBHI,CUTS,SLTSIZ,NSLOT,SLOT,
     .RMIN,RMAX)
C
      IMPLICIT NONE
C 
      INTEGER      NAXIS,NPIX(*),SUBLO(*),SUBHI(*),NSLOT
      INTEGER      LOWX,LOWY,LOWZ,HIX,HIY,HIZ
      INTEGER      N,OFF,YOFF,ZOFF,NX,NY,NZ
      INTEGER      NPX,NPXY,X
C 
      REAL         ARRAY(*),SLOT(*)
      REAL         SLTSIZ,CUTS(2),F,R, RMIN, RMAX
C
C  clear slots
      RMIN = 0.
      RMAX = 0.
      DO 100, N=1,NSLOT
         SLOT(N) = 0
100   CONTINUE
      F = 1./SLTSIZ
C
C  determine subarea
      LOWX = SUBLO(1)
      HIX = SUBHI(1)
      NPX = NPIX(1)
      IF (NAXIS.GE.2) THEN
         LOWY = SUBLO(2)
         HIY = SUBHI(2)
         NPXY = NPX * NPIX(2)
      ELSE
         LOWY = 1
         HIY = 1
         NPXY = NPX
      ENDIF
      IF (NAXIS.GE.3) THEN
         LOWZ = SUBLO(3)
         HIZ = SUBHI(3)
      ELSE
         LOWZ = 1
         HIZ = 1
      ENDIF
C
      ZOFF = (LOWZ-1) * NPXY
      YOFF = (LOWY-1) * NPX
C
C  test, if we have excess bins
      IF (CUTS(2).LE.CUTS(1)) GOTO 1000
C
C  main loop over all pixels in given area with excess bins
      DO 800, NZ=LOWZ,HIZ
C
         DO 600, NY=LOWY,HIY
            OFF = ZOFF + YOFF
C
            DO 500, NX=LOWX,HIX
               N = OFF + NX
               IF (ARRAY(N).GT.CUTS(2)) THEN
                  X = NSLOT                        !high excess bin
               ELSE
                  R = ARRAY(N) - CUTS(1)
                  IF (R.LT.0.) THEN
                     X = 1                  	!low excess bin
                  ELSE
                     X = INT(F*R) + 2                  !valid bin
                  ENDIF
               ENDIF
               SLOT(X) = SLOT(X) + 1
               RMAX    = AMAX1(RMAX, SLOT(X))
500         CONTINUE
C
            YOFF = YOFF + NPX
600      CONTINUE
C
         ZOFF = ZOFF + NPXY
800   CONTINUE
C
C  that's it
      RETURN
C
C  main loop over all pixels in given area without excess bins
1000  DO 1800, NZ=LOWZ,HIZ
C
         DO 1600, NY=LOWY,HIY
            OFF = ZOFF + YOFF
C
            DO 1500, NX=LOWX,HIX
               N = OFF + NX
               X = INT(F*(ARRAY(N)-CUTS(1))) + 1
               SLOT(X) = SLOT(X) + 1
               RMAX    = AMAX1(RMAX, SLOT(X))
1500        CONTINUE
C
            YOFF = YOFF + NPX
1600     CONTINUE
C
         ZOFF = ZOFF + NPXY
1800  CONTINUE
C
      RETURN
      END