C @(#)stseed.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:46 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