C @(#)tdcmph.for 17.1.1.1 (ESO-IPG) 01/25/02 17:47:13 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.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 010110 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 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