C @(#)mltobj.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:42 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.INPUT/OUTPUT C Input arguments C A real*4 array image buffer C JAPY integer*4 array pointers to buffer lines C IBUF integer*4 array limits of image buffer C JBE integer*4 end of buffer C IXYU integer*4 array limits of used area C NC integer*4 number of entries in catalog buffer C MCAT integer*4 array integer detections buffer C BCAT real*4 array real detections buffer C NL integer*4 number of entries in detections buffer C M integer*4 number of detections C MMB integer*4 position in buffer C MOB integer*4 buffer offset C IARR integer*4 array integer parameters C RARR ral*4 array real parameters C output parameters C ACAT real*4 array objects buffer C MM integer*4 number of objects C C----------------------------------------------------------------------- SUBROUTINE MLTOBJ ( A , JAPY , IBUF , JBE , IXYU , ACAT , NC , & MCAT , BCAT , NL , M , MM , MMB , MOB , IARR , RARR ) C IMPLICIT NONE INTEGER NC , NL, ISTAT C INTEGER IARR(32) , IAV , IAV1 , IAV2 , IBUF(4) , IDPM(5) INTEGER II , II1 , II2 , IM , ISIZ , IXYU(4) INTEGER JAPY(1) , JAV , JAV1 , JAV2 , JBE INTEGER JJ , JJ1 , JJ2 , JM , JOFF INTEGER M , MCAT(4,NL) , MINCR , MM , MMB , MOB C REAL A(1) , ACAT(5,NC) , ADLM REAL AVBG , AVI , AVII , AVIJ , AVJ , AVJJ , AVM REAL BCAT(2,NL) , GCUT , RARR(64) REAL ELON , TEMP , THETA , TRLM , TRSH C LOGICAL OBJECT , SINGLE , UNUSED C CHARACTER*80 TEXT C JOFF = IBUF(2) - 1 GCUT = 0.9 * RARR(2) TRSH = RARR(3) ADLM = RARR(42) MINCR = IARR(22) C C ****** Calculate parameters for multiple detection. C OBJECT = .FALSE. SINGLE = .TRUE. CALL MLTDET( MCAT , BCAT , NL , M , MOB , AVI , AVJ , AVII , & AVIJ , AVJJ , AVBG , IM , JM , AVM , ISIZ , OBJECT ) IF ( .NOT. OBJECT ) THEN RETURN ENDIF C C ****** Check if object is elongated. C CALL OBJSHP( AVI , AVJ , AVII , AVIJ , AVJJ , ELON , THETA ) IF ( ELON .LT. RARR(44) ) THEN C C ****** One object is catalogued. C IF ( MMB .EQ. NC ) THEN WRITE (TEXT,'(A)') 'Too many detections' CALL STTPUT(TEXT,ISTAT) c CALL CTLG( ITF , START , STEP , ACAT , NC , MM , MMB ) c MMB = 0 ENDIF MMB = MMB + 1 MM = MM + 1 IF ( AVM .GT. (RARR(2)-AVBG)/1.1 ) THEN IM = NINT(AVI) JM = NINT(AVJ) ELSE AVI = FLOAT(IM) AVJ = FLOAT(JM) ENDIF ACAT(1,MMB) = AVI ACAT(2,MMB) = AVJ ACAT(3,MMB) = AVBG ACAT(4,MMB) = AVM TRLM = AVBG + TRSH CALL RADDET( A , JAPY , IBUF , IM , JM , & IARR(22) , TRLM , AVM , TRSH , ACAT(5,MMB) ) IF ( ACAT(5,MMB) .LE. 0.0 .AND. AVM .LT. GCUT ) THEN MMB = MMB - 1 MM = MM - 1 ENDIF ELSE C C ****** Try to find two objects. C UNUSED = .TRUE. CALL DOUBLE( A , JAPY , JOFF , JBE , IXYU , IARR(8) , & AVBG , AVI , AVJ , THETA , ISIZ , RARR(42) , & RARR(45) , RARR(46) , RARR(3) , IDPM ) AVI = AVI - 0.001 AVJ = AVJ - 0.001 C C ****** Array IDPM contains informations C ****** about double components. C IF ( IDPM(1) .EQ. 2 ) THEN IAV1 = NINT( AVI + IDPM(2) ) JAV1 = NINT( AVJ + IDPM(3) ) IF ( MAX( ABS(IAV1-IM) , ABS(JAV1-JM) ) .LE. 2 ) THEN IAV1 = IM JAV1 = JM UNUSED = .FALSE. ENDIF IF ( IAV1 .GE. IARR(12) .AND. IAV1 .LE. IARR(14) & .AND. JAV1 .GE. IARR(13) .AND. JAV1 .LE. & IARR(15) ) THEN C C ****** Subroutine DOUBLE has produced C ****** at least one new position. C CALL OBJMNG( A , JAPY , IBUF , ACAT , NC , & MM , MMB , IAV1 , JAV1 , AVBG , & TRSH , GCUT , MINCR ) SINGLE = .FALSE. IAV2 = NINT( AVI + IDPM(4) ) JAV2 = NINT( AVJ + IDPM(5) ) IF ( UNUSED .AND. MAX( ABS(IAV2-IM) , ABS(JAV2-JM) ) & .LE. 2 ) THEN IAV2 = IM JAV2 = JM ELSE TEMP = A(JAPY(JAV2-JOFF)+IAV2) II1 = MAX( IAV2-2 , IBUF(1) ) II2 = MIN( IAV2+2 , IBUF(3) ) JJ1 = MAX( JAV2-2 , IBUF(2) ) JJ2 = MIN( IAV2+2 , IBUF(4) ) DO 10 JJ = JJ1 , JJ2 DO 20 II = II1 , II2 IF ( A(JAPY(JJ-JOFF)+II) .GT. TEMP ) & THEN IAV2 = II JAV2 = JJ TEMP = A(JAPY(JJ-JOFF)+II) ENDIF 20 CONTINUE 10 CONTINUE ENDIF TEMP = SQRT( FLOAT( (IAV1-IAV2)*(IAV1-IAV2) + & (JAV1-JAV2)*(JAV1-JAV2) ) ) IF ( TEMP .GE. ADLM .AND. IAV2 .GE. IARR(12) .AND. & IAV2 .LE. IARR(14) .AND. JAV2 .GE. IARR(13) & .AND. JAV2 .LE. IARR(15) ) THEN C C ****** Fainter component is catalogued. C CALL OBJMNG( A , JAPY , IBUF , ACAT , NC , & MM , MMB , IAV2 , JAV2 , AVBG , & TRSH , GCUT , MINCR ) SINGLE = .FALSE. ENDIF ENDIF ELSE IF ( IDPM(1) .EQ. 1 ) THEN SINGLE = .TRUE. ENDIF IF ( SINGLE ) THEN C C ****** Is case that subroutine DOUBLE has C ****** produced no acceptable position C ****** of an object, the highest out of C ****** multiple detection is catalogued. C IF ( AVM .LE. (RARR(2)-AVBG)/1.1 ) THEN IAV = IM JAV = JM ELSE IAV = NINT(AVI) JAV = NINT(AVJ) ENDIF CALL OBJMNG( A , JAPY , IBUF , ACAT , NC , & MM , MMB , IAV , JAV , AVBG , & TRSH , GCUT , MINCR ) ENDIF ENDIF C RETURN C END