C @(#)newobj.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:43 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 NEWOBJ version 1 820624 C A. Kruszewski ESO Garching C modified for FX version 1.1 870303 C A. Kruszewski Obs. de Geneve C.PURPOSE C adds new objects detected by subroutine "PRANLZ" to a master list C of objects C.INPUT/OUTPUT C input arguments C A real*4 array image frame C N1 integer*4 x-dimension of array A C N2 integer*4 y-dimension of array A C I integer*4 x-position of object C J integer*4 y-position of object C NCAT integer*4 array integer parameters of objects C PMTR real*4 array array holding objects' parameters C L integer*4 identification number of an object C MM integer*4 actual number of catalogued objects C TRSH real*4 limiting threshold C ADLM real*4 minimum acceptable separation C between components in pixels C MCM integer*4 array array holding informations about C new objects C output parameters C NCAT integer*4 array integer parameters of objects C PMTR real*4 array array holding objects' parameters C MM integer*4 actual number of catalogued objects C C----------------------------------------------------------------------- SUBROUTINE NEWOBJ(A, JAPY, IBUF, I, J, & NREG, LSTP, NCAT, PMTR, PRCT, & L, L0, L1, LW, MM, & TRSH, ADLM, MCM) C IMPLICIT NONE INCLUDE 'MID_REL_INCL:INVENT.INC' C REAL A(1) INTEGER JAPY(1) INTEGER IBUF(4) INTEGER I INTEGER J INTEGER NREG INTEGER LSTP(0:4,0:NREG) INTEGER NCAT(NIPAR,MAXCNT) REAL PMTR(NRPAR,MAXCNT) REAL PRCT(0:MAXSUB,MAXCNT) INTEGER L INTEGER L0 INTEGER L1 INTEGER LW INTEGER MM REAL TRSH REAL ADLM INTEGER MCM(21) C INTEGER ID(10) INTEGER IDL, IDLM INTEGER IDX, IDY INTEGER II INTEGER IL, IL1 INTEGER ILX, ILY INTEGER IK, IK1, IK2 INTEGER JDLM INTEGER JJ INTEGER JK, JK1, JK2 INTEGER JOF INTEGER K, KL , KL1 INTEGER LL, LZ INTEGER LLX, LLY INTEGER L1B, LWB, LACT, LAZ INTEGER NI, NJ, NP INTEGER MZ INTEGER IXY(2,10) INTEGER NCT(NIPAR) INTEGER NCT1(NIPAR) C REAL XOBJ, YOBJ REAL XCMP, YCMP REAL DIST REAL SUM REAL PMT(NRPAR) REAL PMT1(NRPAR) REAL PRC(0:MAXSUB) REAL PRC1(0:MAXSUB) C LOGICAL DONE C NP = MAXCNT LZ = L - L0 IDLM = MAX( 1 , NINT(ADLM)-1 ) IDL = NINT(ADLM*ADLM) JDLM = NINT(ADLM) + 1 C C *** Recall number of detected new objects KL. C KL=MCM(1) C C *** Prepare blank arrays. C IF ( MM+KL .GT. L0+NP ) THEN DO 5 K = 1 , NIPAR NCT(K) = 0 5 CONTINUE DO 6 K = 1 , NRPAR PMT(K) = 0.0 6 CONTINUE DO 7 K = 0 , MAXSUB PRC(K) = 0.0 7 CONTINUE ENDIF DO 8 K = 1 , 10 ID(K) = 0 8 CONTINUE C C *** Form array with new objects coordinates. C DO 10 IL = 1 , KL IXY(1,IL) = MCM(2*IL) IXY(2,IL) = MCM(2*IL+1) 10 CONTINUE C C *** Mark existance of objects. C DO 20 IL = 1 , KL ID(IL) = 1 20 CONTINUE C C *** Parent object coordinates may be shifted. C NI = I - NCAT(1,LZ) NJ = J - NCAT(2,LZ) C C *** Combine multiple detections. C KL1 = KL - 1 DO 30 IL = 1 , KL1 IL1 = IL + 1 DO 40 LL = IL1 , KL IDX = IXY(1,IL) - IXY(1,LL) IDY = IXY(2,IL) - IXY(2,LL) IF ( IDX*IDX+IDY*IDY .LT. IDL ) THEN ILX = IXY(1,IL) + NI ILY = IXY(2,IL) + NJ LLX = IXY(1,LL) + NI LLY = IXY(2,LL) + NJ IF ( A(JAPY(LLY-IBUF(2)+1)+LLX) .GT. & A(JAPY(ILY-IBUF(2)+1)+ILX) ) THEN ID(LL) = 0 ELSE ID(IL) = 0 ENDIF ENDIF 40 CONTINUE 30 CONTINUE C C *** Look for already filed object closer than ADLM. C DO 50 IL = 1 , KL IF ( ID(IL) .EQ. 1 ) THEN C C *** Trial filing of a new object. C L1B = L1 LWB = LW C IF ( MM+1 .GT. L0 .AND. MM+1 .LE. L0+NP ) THEN L1 = MAX( L1 , MM+1 ) NCAT(1,MM+1-L0) = IXY(1,IL) NCAT(2,MM+1-L0) = IXY(2,IL) C ELSE C NCT(1) = IXY(1,IL) C NCT(2) = IXY(2,IL) C NCT(7) = 0 C NCT(8) = 0 C WRITE ( ISF , REC = MM+1 ) NCT , PMT , PRC C LW = MAX( LW , MM+1 ) C ENDIF CALL PUTLSS( MM+1 , NREG , LSTP , NCAT , PMTR , PRCT ) C IF ( MM+1 .LE. L0 .OR. MM+1 .GT. L0+NP ) THEN C READ ( ISF , REC = MM+1 ) NCT , PMT , PRC C ENDIF C C *** Check if there is already another object closer than ADLM. C LACT = 0 72 CONTINUE CALL GETLST( MM+1 , L0 , L1 , JDLM , NREG , & LSTP , NCAT , PMTR , PRCT , LACT , & NCT1 , PMT1 , PRC1 , DONE ) IF ( DONE ) THEN XOBJ = FLOAT(IXY(1,IL)) YOBJ = FLOAT(IXY(2,IL)) C IF ( LACT .GT. L0 .AND. LACT .LE. L1 ) THEN LAZ = LACT - L0 XCMP = PMTR(10,LAZ) YCMP = PMTR(11,LAZ) C ELSE C XCMP = PMT1(10) C YCMP = PMT1(11) C ENDIF DIST = SQRT( (XOBJ-XCMP)**2.0 + (YOBJ-YCMP)**2.0 ) IF ( DIST .LT. ADLM ) THEN DONE = .TRUE. ELSE GOTO 72 ENDIF ENDIF IF ( .NOT. DONE ) THEN C C *** Catalogue new object. C MM = MM + 1 C IF ( MM .GT. L0 .AND. MM .LE. L0+NP ) THEN MZ = MM - L0 NCAT(1,MZ) = MCM(2*IL) NCAT(2,MZ) = MCM(2*IL+1) PMTR(10,MZ) = FLOAT(NCAT(1,MZ)) PMTR(11,MZ) = FLOAT(NCAT(2,MZ)) c NCAT(4,MZ) = 0 PMTR(1,MZ) = PMTR(1,LZ) IK = NCAT(1,MZ) + NI JK = NCAT(2,MZ) + NJ IF ( IK .LE. IBUF(1) .OR. IK .GE. IBUF(3) & .OR. JK .LE. IBUF(2) & .OR. JK .GE. IBUF(4) ) THEN PMTR(2,MZ) = 0.0 GOTO 71 ENDIF SUM = 0.0 IK1 = IK - 1 IK2 = IK + 1 JK1 = JK - 1 JK2 = JK + 1 DO 60 JJ = JK1 , JK2 JOF = JAPY(JJ-IBUF(2)+1) DO 70 II = IK1 , IK2 SUM = SUM + A(JOF+II) 70 CONTINUE 60 CONTINUE PMTR(2,MZ) = SUM / 9.0 - PMTR(1,MZ) 71 CONTINUE IF ( PMTR(2,MZ) .LT. TRSH ) THEN CALL RMFLST( MM , L0 , L1 , NREG , & LSTP , NCAT ) MM = MM - 1 L1 = L1B LW = LWB ENDIF C ELSE C NCT(1) = MCM(2*IL) C NCT(2) = MCM(2*IL+1) C PMT(10) = FLOAT(NCT(1)) C PMT(11) = FLOAT(NCT(2)) C NCT(4) = 0 C PMT(1) = PMTR(1,LZ) C IK = NCT(1) + NI C JK = NCT(2) + NJ C IF ( IK .LE. IBUF(1) .OR. IK .GE. IBUF(3) C & .OR. JK .LE. IBUF(2) C & .OR. JK .GE. IBUF(4) ) THEN C PMT(2) = 0.0 C GOTO 91 C ENDIF C SUM = 0.0 C IK1 = IK - 1 C IK2 = IK + 1 C JK1 = JK - 1 C JK2 = JK + 1 C DO 80 JJ = JK1 , JK2 C JOF = JAPY(JJ-IBUF(2)+1) C DO 90 II = IK1 , IK2 C SUM = SUM + A(JOF+II) C 90 CONTINUE C 80 CONTINUE C PMT(2) = SUM / 9.0 - PMT(1) C 91 CONTINUE C IF ( PMT(2) .LT. TRSH ) THEN C CALL RMFLST( ISF , MM , L0 , L1 , NREG , C & LSTP , NCAT ) C MM = MM - 1 C L1 = L1B C LW = LWB C ELSE C WRITE ( ISF , REC=MM ) NCT , PMT , PRC C ENDIF C ENDIF ELSE C C *** Remove back an added object from the list. C CALL RMFLST( MM+1 , L0 , L1 , NREG , & LSTP , NCAT ) L1 = L1B LW = LWB ENDIF ENDIF 50 CONTINUE C RETURN C END C