C @(#)invclass.for	17.1.1.1 (ESO-DMD) 01/25/02 17:15:58
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.IDENTIFICATION:  INVCLASS.FOR
C.PURPOSE:         Classifies objects into stars,galaxies and image defects
C.AUTHOR:          A. Kruszewski             ESO Garching
C.LANGUAGE:        F77+ESOext
C.INPUT/OUTPUT:    INPUT:  input table, result of the analyse command
C                  OUTPUT: on the same table in column 21: classify results
C.VERSION:         AK   831017  Creation
C.VERSION:         CHO. 850115  ???
C.VERSION:         KB   870520  ???
C.VERSION:         AK   870729  ???
C.VERSION:         RHW  871121  ESO-FORTRAN Conversion
C -------------------------------------------------------------------
      PROGRAM   CLASSI
C
      IMPLICIT  NONE
      INCLUDE   'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER   ITF,IACOL,IAROW
      INTEGER   IAC,IST
      INTEGER   ICLS(2,MAXCNT)
      INTEGER   ITLM(2)
      INTEGER   NCOL,NN,NROW 
      INTEGER   KUN,KNUL
C
      REAL      PMTR(30,MAXCNT)
      REAL      STPR(MAXSUB)
      REAL      CPAR(3)
      REAL      BLMT
      REAL      SGLM
      REAL      TRSH
C
      CHARACTER INTAB*60
C
      LOGICAL   FAIL
C
      INCLUDE   'MID_INCLUDE:TABLES.INC/NOLIST'
      INCLUDE   'MID_INCLUDE:TABLED.INC/NOLIST'
C
      CALL STSPRO('CLASSIFY')
C
      CALL STKRDC('IN_B',1,1,60,IAC,INTAB,KUN,KNUL,IST)
      FAIL   = .FALSE.
C
      CALL TBTOPN(INTAB, F_U_MODE, ITF, IST)
      CALL TBIGET(ITF, NCOL, NROW, NN, IACOL, IAROW, IST)
C
C *** Prepare the array PMTR
C
      CALL COPY(ITF,23,NROW,NROW,PMTR)
C
C *** Prepare the array STPR and the values TRSH,BLMT,SGLM,CPAR,ITLM
C
      CALL STDRDR(ITF, 'DPROFILE', 1, MAXSUB, IAC, STPR, KUN, KNUL, IST)
C
      CALL STKRDR('INV_REAL', 3, 1, IAC, TRSH, KUN, KNUL, IST)
      CALL STKRDR('INV_REAL', 8, 1, IAC, BLMT, KUN, KNUL, IST)
      CALL STKRDR('INV_REAL', 9, 1, IAC, SGLM, KUN, KNUL, IST)
      CALL STKRDR('INV_REAL', 5, 3, IAC, CPAR, KUN, KNUL, IST)
      CALL STKRDI('INV_INTG', 17, 2, IAC, ITLM, KUN, KNUL, IST)
C
C *** Perform classification.
C
      CALL CLPMTR(PMTR, ICLS, NROW, STPR, TRSH, FAIL)
      IF (.NOT. FAIL) THEN
C
C *** Copy the results ICLS(2,I) in column 21 of INTAB.
C
          CALL COPY1(ITF, 23, NROW, NROW, ICLS)
      END IF
C
C *** Write used parameters as table descriptors
C
      CALL STDWRR(ITF, 'CLASSPAR', CPAR, 1, 3, KUN, IST)
      CALL STDWRR(ITF, 'BRGHTLMT', BLMT, 1, 1, KUN, IST)
      CALL STDWRR(ITF, 'DISTANCE', SGLM, 1, 1, KUN, IST)
      CALL STDWRI(ITF, 'ITERATE', ITLM, 1, 2, KUN, IST)
C
      CALL TBTCLO(ITF, IST)
      CALL STSEPI
      END

C
C ***********************************************************
C
      SUBROUTINE COPY(TID,NTCOL,NTROW,NROW,OUTB)
C
      IMPLICIT NONE
      INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER  TID
      INTEGER  NTCOL
      INTEGER  NTROW
      INTEGER  NROW
      REAL     OUTB(30,MAXCNT)
C
      INTEGER  I
      INTEGER  ICOL(30)
      INTEGER  ISTAT
      INTEGER  J
      INTEGER  KUNR(30)
      REAL     FINTB(30)
C
      DATA    ICOL/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,
     2             11,12,13,14,15,16,17,18,19,20,
     3             21,22,23,24,25,26,27,28,29,30/
C
      DO 20 I = 1,NROW
         CALL TBRRDR(TID,I,NTCOL,ICOL,FINTB,KUNR,ISTAT)
         OUTB(1,I)  = FINTB(9)
         OUTB(2,I)  = FINTB(10)
         OUTB(3,I)  = FINTB(7)
         OUTB(4,I)  = FINTB(8)
         OUTB(5,I)  = FINTB(20)
         OUTB(6,I)  = FINTB(11)
         OUTB(7,I)  = FINTB(12)
         OUTB(8,I)  = FINTB(13)
         OUTB(9,I)  = FINTB(14)
         OUTB(10,I) = FINTB(2)
         OUTB(11,I) = FINTB(3)
         OUTB(12,I) = FINTB(4)
         OUTB(13,I) = FINTB(5)
         OUTB(14,I) = 0.0
         DO 10 J = 15, 19
            OUTB(J,I) = FINTB(J)
   10    CONTINUE
         OUTB(20,I) = FINTB(6)
         OUTB(21,I) = FINTB(21)
         OUTB(22,I) = FINTB(22)
   20 CONTINUE
C
      RETURN
      END
C
C ********************************************************
C
      SUBROUTINE COPY1(TID,NTCOL,NTROW,NROW,ICLS)
C
      IMPLICIT NONE
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER  TID
      INTEGER  NTCOL
      INTEGER  NTROW
      INTEGER  NROW
      INTEGER  ICLS(2,MAXCNT)
C
      INTEGER  I
      INTEGER  IC
      INTEGER  ISTAT
      REAL     FINTB
C
      DATA     IC/21/
C
      DO 10 I = 1,NROW
         FINTB = FLOAT(ICLS(2,I))
         CALL TBRWRR(TID,I,1,IC,FINTB,ISTAT)
   10 CONTINUE
C
      RETURN
      END