C @(#)invsearch.for	19.1 (ES0-DMD) 02/25/03 13:26:21
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
