C @(#)invsearch.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:58 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 C.IDENTIFICATION: INVSEARCH.FOR C.PURPOSE: Searches image frame for objects and create output C table with positions, local background levels, central C intensities, and approximate sizes of found objects. C.LANGUAGE: ESO-FOR C.AUTHOR: A. Kruszewski C.KEYWORDS: SEARCH, STARS, GALAXIES, IMAGES C.ALGORITHM: Described in an additional document. C.REMARKS: Main program for SEARCH/INV command. C.ENVIRONMENT: Portable MIDAS C.COMMENTS: Main program only C.VERSION: JUL81 AK Created as part of INVENTORY program C.VERSION: OCT83 ChO Made separate program C.VERSION: JUL87 AK Indirect pixel addressing C.VERSION: NOV87 RHW ESO-FORTRAN Conversion, AA 8:56 - 23 NOV 1987 C.VERSION: DEC88 AK changes for portability C----------------------------------------------------------------------- PROGRAM SRCOBJ C IMPLICIT NONE C INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST' C INTEGER I , IACT , IARR(32) INTEGER ICOL(6) , ICRCOL(6) INTEGER ILIM , IMF INTEGER*8 IPNTR , JPNTR, KPNTR, LPNTR INTEGER ISTAT , ITF C INTEGER II INTEGER JSIZE INTEGER KNUL , KSIZE , KUN INTEGER LSIZE C INTEGER LN INTEGER MADRID(1) INTEGER M INTEGER NAXIS , NPIX(2) , NX , NXS , NY C REAL ACAT(5,MAXCNT) REAL RARR(64) , TMP(6) C DOUBLE PRECISION START(2) , STEP(2) C CHARACTER*16 LABEL(6) , UNIT(6) CHARACTER*48 CUNIT CHARACTER*60 FRAME , TABNAME CHARACTER*72 IDENT CHARACTER*80 TEXT C C INCLUDE 'MID_INCLUDE:TABLES.INC/NOLIST' INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID C INCLUDE 'MID_INCLUDE:TABLED.INC/NOLIST' INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C DATA UNIT/' ','MICRONS','MICRONS',' ',' ','PIXELS'/ DATA LABEL/'IDENT','X','Y','BG','INT','AR'/ C C *** Enter Midas environment. C CALL STSPRO('SEARCHOBJ') C C *** Read names of input frame and output table. C CALL STKRDC('IN_A', 1, 1, 60, IACT, & FRAME, KUN, KNUL, ISTAT) CALL STKRDC('OUT_A', 1, 1, 60, IACT, & TABNAME, KUN, KNUL, ISTAT) C C *** Open bulk data frame and read standard descriptors. C CALL STIGET(FRAME, D_R4_FORMAT, F_I_MODE, F_IMA_TYPE, 2, & NAXIS, NPIX, START, STEP, IDENT , & CUNIT, IPNTR, IMF, ISTAT) NX = NPIX(1) NY = NPIX(2) C C *** Read keywords. C CALL RDKINV(IARR, RARR, ISTAT) C C *** Find borders of an area on which the search shall be made. C *** It has the form of rectangle. The keyword PHYSICAL = IARR(7) C *** tells if the search rectangle is defined by physical C *** coordinates RARR(54) - RARR(57) (IARR(7)=1), or by C *** pixel coordinates IARR(12) - IARR(15) (IARR(7)=0). C IF ( IARR(7) .EQ. 1 ) THEN IARR(12) = 1 + NINT((DBLE(RARR(54)) - START(1))/STEP(1)) IARR(13) = 1 + NINT((DBLE(RARR(55)) - START(2))/STEP(2)) IARR(14) = 1 + NINT((DBLE(RARR(56)) - START(1))/STEP(1)) IARR(15) = 1 + NINT((DBLE(RARR(57)) - START(2))/STEP(2)) ENDIF C C *** Default is whole frame. C IF (IARR(14).LE. MAX(IARR(12), 0)) THEN IARR(12) = 1 IARR(14) = NX ENDIF IF (IARR(15).LE. MAX(IARR(13),0)) THEN IARR(13) = 1 IARR(15) = NY ENDIF C C *** Frame margins IARR(19)-pixels wide are not searched. C IARR(12) = MAX(IARR(12), IARR(19)+1) IARR(13) = MAX(IARR(13), IARR(19)+1) IARR(14) = MIN(IARR(14), NX-IARR(19)) IARR(15) = MIN(IARR(15), NY-IARR(19)) C C *** NXS - number of searched pixels in a line. C NXS = IARR(14) - IARR(12) + 1 C C *** Allocate memory for detection marking rolling array. C ILIM = INT(RARR(43)) KSIZE = 4 * (ILIM+1) * NXS CALL TDMGET(KSIZE, KPNTR, ISTAT) C C *** Allocate memory for array that set half-circle C *** of ILIM radius in detection marking array. C LSIZE = 8 * (ILIM+1) CALL TDMGET(LSIZE, LPNTR, ISTAT) C C *** Allocate memory for line pointers array. C JSIZE = 4 * NY CALL TDMGET(JSIZE, JPNTR, ISTAT) C C *** Perform calculations. C CALL SEARCH(IMF, MADRID(IPNTR), MADRID(JPNTR), NX, NY, & ACAT, MADRID(KPNTR), MADRID(LPNTR), IARR, RARR, & M) C WRITE (TEXT,'(A)') ' search completed' CALL STTPUT(TEXT , ISTAT) C C *** Create output table. C IF (M.GT.0) THEN CALL TBTINI(TABNAME,0,F_O_MODE,6,M,ITF,ISTAT) DO 10 I = 1, 6 CALL TBCINI(ITF, D_R4_FORMAT, 1, 'E12.4', UNIT(I), & LABEL(I), ICRCOL(I), ISTAT) 10 CONTINUE C C *** Write results into output table. C DO 20 I = 1, 6 ICOL(I) = I 20 CONTINUE DO 30 I = 1, M TMP(1) = FLOAT(I) TMP(2) = SNGL(START(1) + DBLE(ACAT(1,I)-1.0)*STEP(1)) TMP(3) = SNGL(START(2) + DBLE(ACAT(2,I)-1.0)*STEP(2)) TMP(4) = ACAT(3,I) TMP(5) = ACAT(4,I) - TMP(4) TMP(6) = ACAT(5,I) CALL TBRWRR(ITF, I, 6, ICOL, TMP, ISTAT) 30 CONTINUE C C *** Write descriptors into table. C CALL STDWRD(ITF, 'START', START, 1, 2, KUN, ISTAT) CALL STDWRD(ITF, 'STEP', STEP, 1, 2, KUN, ISTAT) C C *** Close output table. C CALL TBSINI( ITF , ISTAT ) CALL TBTCLO( ITF , ISTAT ) ENDIF C CALL TDMFRE(JSIZE, JPNTR, ISTAT) CALL TDMFRE(KSIZE, KPNTR, ISTAT) CALL TDMFRE(LSIZE, LPNTR, ISTAT) C C *** Quit Midas environment. C CALL STSEPI c STOP ' ' END