C @(#)stseed.for	19.1 (ES0-DMD) 02/25/03 13:25:40
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.IDENTIFICATION
C  subroutine STSEED         version 1.1        870729
C  A. Kruszewski             ESO Garching
C.PURPOSE
C  Set seed classifications of objects that are surely stars or galaxies.
C.ALGORYTHM
C  The relative gradient is used for intial separation. Three parameters
C  are used for defining the stars and galaxies regions. If there is a too
C  small number of objects in a particular region then this region is
C  enlarged until regions overlap.
C.INPUT/OUTPUT
C  input arguments
C  PMTR        real*4 array      array holding classifiers
C  BRGT        logical array     array indicating saturated objects
C  M           integer*4         number of objects
C  TRSH        real*4            detection treshold above the sky background
C  output arguments
C  ICLS        integer*4 array   array holding the seed classification
C                                coded: 0-unclassified, 1-star, 2-galaxy
C                                in elements ICLS(1,*)
C  PMTR        real*4 array      modified classifiers holding array
C-----------------------------------------------------------------------
      SUBROUTINE STSEED(PMTR,BRGT,ICLS,M,TRSH,FAIL)
C
      IMPLICIT NONE
      INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST'
C
      REAL         PMTR(30,MAXCNT)
      LOGICAL      BRGT(MAXCNT)
      INTEGER      ICLS(2,MAXCNT)
      INTEGER      M	
      REAL         TRSH
      LOGICAL      FAIL
C
      INTEGER      I
      INTEGER      IAC
      INTEGER      ISTAT
      INTEGER      KUN, KNUL
      INTEGER      NS, NG
      REAL         ALS, ALG, ALT
      REAL         CLPR(3)
      REAL         TEMP
      REAL         TVAR
      LOGICAL      COND
      CHARACTER*80 OUTPUT
C
C     ALS-range of relative gradients for stars.
C     ALG-upper limit of relative gradients for galaxies.
C *** ALT-lower limit of central intensity in terms of TRSH.
C     NS-number of seed stars.
C     NG-number of seed galaxies.
C
      CALL STKRDR( 'INV_REAL' , 5 , 3 , IAC , CLPR , KUN , KNUL , ISTAT)
C
      ALS    = CLPR(1)
      ALG    = CLPR(2)
      ALT    = CLPR(3)
      NS     = 0
      NG     = 0
C
C     Initiates logical variable FAIL which is
C *** used for signaling the inability to find
C     sufficient number of seed objects.
C
      FAIL   = .FALSE.
C
C *** Terminates execution when there is too few or too many objects.
C
      IF (M.LT.40 .OR. M.GT.MAXCNT) THEN
          FAIL   = .TRUE.
      END IF
C
C *** Initiates faint objects elements of array ICLS.
C
      IF ( .NOT. FAIL) THEN
          DO 10 I = 1,M
              IF ( .NOT. BRGT(I)) THEN
                  ICLS(1,I) = 0
                  ICLS(2,I) = 0
              END IF

   10     CONTINUE
      END IF
C
C     Repeates selection of seed objects until
C *** there are at least 20 objects in each
C     cathegory and object regions do not overlap.
C

   30 CONTINUE
          COND   = ((NS.LT.20) .OR. (NG.LT.20)) .AND. ( .NOT. FAIL)
     &                              .AND. (ALG.LE.-ALS)
          IF ( .NOT. (COND)) GO TO 40
C
C *** Clear object counters.
C
          NS     = 0
          NG     = 0
C
C *** Perform the segregation.
C
          DO 20 I = 1,M
              IF ((.NOT.BRGT(I))) THEN
                  TEMP   = PMTR(3,I)
                  TVAR   = PMTR(2,I)/TRSH
                  IF (TEMP.GT. (-ALS) .AND. TEMP.LT.ALS .AND. TVAR.GT.
     +                ALT) THEN
                      NS     = NS + 1
                      ICLS(1,I) = 1
                      ICLS(2,I) = 1

                  ELSE IF (TEMP.LT.ALG .AND. TVAR.GT.0.5*ALT) THEN
                      NG     = NG + 1
                      ICLS(1,I) = 2
                      ICLS(2,I) = 2
                  END IF

              END IF

   20     CONTINUE
C
C *** Modify the criteria.
C
          IF (NS.LT.20) THEN
              ALS    = ALS + 0.01
              ALT    = 1.0 + (ALT-1.0)/2.0
          END IF

          IF (NG.LT.20) THEN
              ALG    = ALG + 0.01
          END IF
C
C      Signal failure when star and galaxy
C ***  regions overlap and there is not enough
C      stars in at least one class of objects.
C
          IF ((ALG.GT.-ALS) .AND. ((NS.LT.20).OR. (NG.LT.20))) THEN
              FAIL   = .TRUE.
          END IF
      GO TO 30
   40 CONTINUE
C
C *** Abnormal termination of the execution.
C
      IF (FAIL) THEN
          IF (M.GT.5000) THEN
              WRITE (OUTPUT,'(A)') 'Too many objects'
              CALL STTPUT(OUTPUT,ISTAT)

          ELSE
              WRITE (OUTPUT,'(A)') 'Unable to find seed objects'
              CALL STTPUT(OUTPUT,ISTAT)
              IF (M.LT.40) THEN
                  WRITE (OUTPUT,'(A)') 'Too few objects'
                  CALL STTPUT(OUTPUT,ISTAT)

              ELSE
                  WRITE (OUTPUT,'(A)') 'Too few objects?'
                  CALL STTPUT(OUTPUT,ISTAT)
              END IF

          END IF
      END IF
C
      RETURN
      END
