C @(#)serch.for 17.1.1.1 (ES0-DMD) 01/25/02 17:19:01 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.LANGUAGE: F77+ESOext C.AUTHOR: P.Stetsan C.IDENTIFICATION: SERCH C.KEYWORDS: photometry,astrometry C.PURPOSE: Subroutine to search for a star from a marginal distribution. C.ALGORITHM; see Stetson, P.B., 1979 Astron. J., 84 1149 C.INPUT/OUPUT: -> KRX marginal data REAL*8 C -> NX dimension of KRX C -> KK number of points ignored at each end of KRX C ( greater than or equal to 2) C <- XO output estimate of the image centre C <- SX output estimate of the image with C <-> JX Low-side local minimum (stepped in by one) C <-> LX High-side local minimum (stepped in by one) C -> KDRX work array dimension as KRX, REAL*8 C -> ICROWD 0 if no other star is detected in the field C -1 if a brighter star is found on the low side C +1 if a brighter star is found on the high side C.VERSION: 8212?? A.P. Stetson Creation C.VERSION: ?????? H.Waldthausen VAX-implementation C.VERSION: 871123 Rein H. Warmels ESO-FORTRAN Conversion C ------------------------------------------------------------------- SUBROUTINE SERCH(KRX,NX,KK,XO,SX,JX,LX,KDRX,ICROWD) C IMPLICIT NONE DOUBLE PRECISION KRX(1) INTEGER NX INTEGER KK REAL XO REAL SX INTEGER JX INTEGER LX DOUBLE PRECISION KDRX(1) INTEGER ICROWD C INTEGER I, IBEG, IEND INTEGER IMIN, IMAX INTEGER J INTEGER L INTEGER M INTEGER N C DOUBLE PRECISION KDRMX DOUBLE PRECISION KDRMN DOUBLE PRECISION KKS C ICROWD = 0 IBEG = KK + 1 IEND = NX - KK N = NX - 2 KDRMX = 0 KDRMN = 0 C C *** find maximum and minimum derivative of KRX C DO 10 I = IBEG,IEND KKS = KRX(I+1) - KRX(I-1) KDRX(I) = KRX(I+2) - KRX(I-2) + KKS + KKS IF (KDRX(I).GE.KDRMX) THEN KDRMX = KDRX(I) IMAX = I END IF IF (KDRX(I).LE.KDRMN) THEN KDRMN = KDRX(I) IMIN = I END IF 10 CONTINUE C C *** crowded ? C bright source to left, compute right a new minima = KDRMN IF (IMIN.LE.IMAX) THEN IF ((NX-IMAX).GE. (IMIN-1)) THEN ICROWD = -1 KDRMN = KDRMX J = IMAX + 1 DO 20 I = J,IEND IF (KDRX(I).LE.KDRMN) THEN KDRMN = KDRX(I) IMIN = I END IF 20 CONTINUE C C *** brigt source to the right, compute left a new maxima = KDRMX C ELSE ICROWD = 1 KDRMX = KDRMN J = IMIN - 1 DO 30 I = IBEG,J IF (KDRX(I).GE.KDRMX) THEN KDRMX = KDRX(I) IMAX = I END IF 30 CONTINUE END IF END IF C C *** compute estimates of image centre and width C KKS = 0 SX = IMIN - IMAX DO 40 I = IMAX,IMIN KKS = KKS + KDRX(I) 40 CONTINUE C XO = 0.5* (IMAX+IMIN) + KKS*SX/ ((SX+1.0)* (KDRMX-KDRMN)) SX = 0.5*SX J = IFIX(XO+0.5) C C *** find low- (left-) side local minimum L = J - 2 JX = 1 50 L = L - 1 C GO TO (100,90,80,70,60),L 60 IF (KRX(L).GT.KRX(L-4)) GO TO 50 70 IF (KRX(L).GT.KRX(L-3)) GO TO 50 80 IF (KRX(L).GT.KRX(L-2)) GO TO 50 90 IF (KRX(L).GT.KRX(L-1)) GO TO 50 JX = L + 1 C C *** find high- (right-) side local minimum\ C 100 L = J + 2 LX = NX M = NX + 1 110 L = L + 1 C GO TO (160,150,140,130,120),M - L 120 IF (KRX(L).GT.KRX(L+4)) GO TO 110 130 IF (KRX(L).GT.KRX(L+3)) GO TO 110 140 IF (KRX(L).GT.KRX(L+2)) GO TO 110 150 IF (KRX(L).GT.KRX(L+1)) GO TO 110 LX = L - 1 C C *** exit C 160 RETURN END