C @(#)invanalys.for	17.1.1.1 (ES0-DMD) 01/25/02 17:15:57
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: ANALYS       VERSION 2.0           840522
C.PURPOSE:        For an input list of objects, calcul of classifying 
C                 parameters,  magnitudes, positions, gradients, profiles
c                 (see inventory user's manual from a. kruszewski)
C.AUTHOR:         A. Kruszewski
C.LANGUAGE:       F77+ESOext
C.KEYWORDS:       classifying parameters, magnitudes, positions, profiles
C.VERSION:        1.0  ESO-FORTRAN Conversion, AA  8:56 - 23 NOV 1987
C.VERSION:        Ch O, ESO - Garching  850115
C.VERSION:        AK, Obs. de Geneva    870303  changes for the Alliant FX
C.VERSION:        AK, ESO Garching      870702  new table column names
C.VERSION         MP, ESO Garching      890216  change length of TYPE
C-----------------------------------------------------------------------
      PROGRAM ANALYS
C
      IMPLICIT NONE
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER   IACOL, IACT, IAROW, IARR(32)
      INTEGER*8  ICOLP, IPNTR, JPNTR, KPNTR, LPNTR
      INTEGER   ICOL(6), IHED, IMF
      INTEGER   ISTAT, ITF, ITOB(4), IXYU(4)
      INTEGER   JSIZE
      INTEGER   KNUL, KSIZE, KUN
      INTEGER   LPXL, LSBP, LSIZE
      INTEGER   MADRID(1)
      INTEGER   NAXIS, NBYTE, NCOLI, NEL
      INTEGER   NCAT(NIPAR,MAXCNT), NPIX(2), NROWI
      INTEGER   NX, NY, NSC
      INTEGER   IMAX, INIP
C
      REAL      PMTR(NRPAR,MAXCNT)
      REAL      PRCT(0:MAXSUB,MAXCNT)
      REAL      RARR(64)
C
      DOUBLE PRECISION  START(2)
      DOUBLE PRECISION  STEP(2)
      DOUBLE PRECISION  DBLONE
C
      CHARACTER*1    TYPE
      CHARACTER*16   COLAR, COLAV9, COLBGD
      CHARACTER*16   COLID, COLISO, COLX, COLY
      CHARACTER*48   CUNIT
      CHARACTER*60   FRAME, INTABL, OUTABL , OUTPSF
      CHARACTER*40   OPTION 
      CHARACTER*72   IDENT
      CHARACTER*80   OUTPUT
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
C *** Start Midas.
C
      CALL STSPRO('ANALYSE')
C
C *** Initialisation of column labels.
C
      DO IMAX = 1, MAXCNT
         DO INIP = 1, NIPAR
            NCAT(INIP,IMAX) = 0
         ENDDO 
      ENDDO

      DBLONE = 1.0
      COLID  = 'IDENT'
      COLX   = 'X'
      COLY   = 'Y'
      COLISO = 'RAD_ISO'
      COLBGD = 'BG'
      COLAV9 = 'INT'
      COLAR  = 'AR'
C
C *** Read arrays IARR and RARR.
C
      CALL RDKINV(IARR, RARR, ISTAT)
C
C *** Read image and tables names.
C
      CALL STKRDC('IN_A', 1, 1, 60, IACT, FRAME, KUN, KNUL, ISTAT)
      CALL STKRDC('IN_B', 1, 1, 60, IACT, INTABL, KUN, KNUL, ISTAT)
      CALL STKRDC('OUT_A', 1, 1, 60, IACT, OUTABL, KUN, KNUL, ISTAT)
      CALL STKRDC('INPUTC', 1, 1, 10, IACT, OPTION, KUN, KNUL, ISTAT)
      CALL STKRDC('OUT_B', 1, 1, 60, IACT, OUTPSF, KUN, KNUL, ISTAT)
C
C *** Open image frame.
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 *** Check if descriptor STARS is present if needed.
C
      IF (IARR(11) .LT. 0) THEN
         CALL STDFND(IMF, 'STARS', TYPE, NEL, NBYTE, ISTAT)
         IF (TYPE .EQ. ' ' .OR. NEL .LE. 0) THEN
            OUTPUT = '*** FATAL: '//
     2               'Descriptor STARS is missing in your frame'
            CALL STTPUT(OUTPUT, ISTAT)
            OUTPUT = '    Create it via GET/CURS STARS/DES or'
            CALL STTPUT(OUTPUT, ISTAT)
            OUTPUT = '    set keyword PRFLCTRL to non-negative value.'
            CALL STTPUT(OUTPUT, ISTAT)
            CALL STSEPI
         ENDIF
      ENDIF
C
C *** Read descriptor DPROFILE after testing its presence.
C
      CALL STDFND(IMF, 'DPROFILE', TYPE, NEL, NBYTE, ISTAT)
      IF (.NOT. (TYPE .EQ. ' ' .OR. NEL .LE. 0)) THEN
         CALL STDRDR(IMF, 'DPROFILE', 1, 25, IACT, RARR(14),
     &               KUN, KNUL, ISTAT)
      ENDIF
C
C *** Find borders of an area on which the search
C *** shall be made. It has the form of rectangle.
C *** The keyword PHYSICAL = IARR(7) tells if the
C *** search rectangle is defined by physical coordinates
C *** RARR(54) - RARR(57) (IARR(7)=1), or by pixel
C *** 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 *** Check if searched region overlaps with the frame.
C
      IF (IARR(12).GE.NX-IARR(19) .OR. IARR(13).GE.
     &             NY-IARR(19) .OR. IARR(14).LE.1+IARR(19)
     &             .OR. IARR(15).LE.1+IARR(19)) THEN
          OUTPUT = '*** FATAL: '//
     &             'Frame and searched region do not overlap'
          CALL STTPUT(OUTPUT, ISTAT)
      ENDIF
C
C *** Frame margins IARR(19)-pixels wide are not used.
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 *** IARR(12) to IARR(15) give limits of searched region.
C *** Temporary objects can be detected in little larger
C *** region bounded by array ITOB.
C
      IHED = IARR(8)
      ITOB(1) = MAX( IARR(12)-IHED , IARR(19)+1 )
      ITOB(2) = MAX( IARR(13)-IHED , IARR(19)+1 )
      ITOB(3) = MIN( IARR(14)+IHED , NX-IARR(19) )
      ITOB(4) = MIN( IARR(15)+IHED , NY-IARR(19) )
C
C *** Data in still larger region is used. It is limited by array IXYU.
C
      IXYU(1) = MAX(ITOB(1)-IHED, 1)
      IXYU(2) = MAX(ITOB(2)-IHED, 1)
      IXYU(3) = MIN(ITOB(3)+IHED, NX)
      IXYU(4) = MIN(ITOB(4)+IHED, NY)
C
C *** Allocate memory for line pointers array.
C
      JSIZE = 4 * NY
      CALL TDMGET(JSIZE, JPNTR, ISTAT)
C
C *** Allocate memory for two dimensional p.s.f.
C
      LPXL  = IARR(20)
      LSBP  = IARR(21)
      KSIZE = 4 * ( (7+NOSP) * (2*LPXL+1)**2 + 1) * (2*LSBP+1)**2
      CALL TDMGET(KSIZE, KPNTR, ISTAT)
      LSIZE = 4 * ( (2*LSBP+1)**2 + NOSP + 1 )
      CALL TDMGET(LSIZE, LPNTR, ISTAT)
C
C *** Open input table.
C
      CALL TBTOPN(INTABL,F_I_MODE,ITF,ISTAT)
C
C *** Read number of input table rows NROWI and columns NCOLI.
C
      CALL TBIGET(ITF, NCOLI, NROWI, NSC, IACOL, IAROW, ISTAT)
C
C *** Find columns X and Y and read them into array NCAT.
C
      CALL TBLSER(ITF, COLX, ICOL(1), ISTAT)
      IF (ICOL(1) .LE. 0 .OR. ISTAT .NE. 0) THEN
         OUTPUT = '*** FATAL: The column label X is not present.'
         CALL STTPUT(OUTPUT, ISTAT)
         CALL STSEPI
      ELSE
         CALL TBCMAP(ITF, ICOL(1), ICOLP, ISTAT)
         CALL TBLAI(MADRID(ICOLP), NROWI, START(1), STEP(1),
     &              NCAT, NIPAR, 1)
         CALL TBLAR(MADRID(ICOLP), NROWI, START(1), STEP(1),
     &              PMTR, NRPAR, 10)
      ENDIF
C
      CALL TBLSER(ITF, COLY, ICOL(2), ISTAT)
      IF (ICOL(2) .LE. 0 .OR. ISTAT .NE. 0) THEN
         OUTPUT = '*** FATAL: The column label Y is not present'
         CALL STTPUT(OUTPUT, ISTAT)
         CALL STSEPI
      ELSE
         CALL TBCMAP(ITF, ICOL(2), ICOLP, ISTAT)
         CALL TBLAI(MADRID(ICOLP), NROWI, START(2), STEP(2),
     &              NCAT, NIPAR, 2)
         CALL TBLAR(MADRID(ICOLP), NROWI, START(2), STEP(2),
     &              PMTR, NRPAR, 11)
      ENDIF
C
C *** Find column RAD_ISO if IARR(5) = 1.
C
      IF (IARR(5) .EQ. 1) THEN
         CALL TBLSER(ITF, COLISO, ICOL(5), ISTAT)
         IF (ICOL(5) .LE. 0 .OR. ISTAT .NE. 0) THEN
            OUTPUT = '*** WARNING: '//
     2               'The column label RAD_ISO is not present'
            CALL STTPUT(OUTPUT, ISTAT)
            ICOL(5) = 0
         ELSE
         CALL TBCMAP(ITF, ICOL(5), ICOLP, ISTAT)
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
     &              NRPAR, 5)
         ENDIF
      ELSE
         ICOL(5) = 0
      ENDIF
C
C *** Find columns LOC_BGD and AVER_9.
C
      CALL TBLSER(ITF, COLBGD, ICOL(3), ISTAT)
      IF (ICOL(3) .LE. 0 .OR. ISTAT .NE. 0) THEN
         ICOL(3) = 0
      ELSE
         CALL TBCMAP(ITF, ICOL(3), ICOLP, ISTAT)
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
     &              NRPAR, 1)
      ENDIF
      CALL TBLSER(ITF, COLAV9, ICOL(4), ISTAT)
      IF (ICOL(4) .LE. 0 .OR. ISTAT .NE. 0) THEN
         ICOL(4) = 0
      ELSE
         CALL TBCMAP(ITF, ICOL(4), ICOLP, ISTAT)
         CALL TBLAR(MADRID(ICOLP), NROWI, DBLONE, DBLONE, PMTR,
     &              NRPAR, 2)
      ENDIF
C
C ***  Find column ID or create its values if absent.
C
C      CALL TXLSER(INTABL,COLID,ICOL(6),ISTAT)
C      IF (ICOL(6).LE.0) THEN
C          DO 10 L = 1,NROWI
C              IDCAT(L) = L
C   10     CONTINUE
C      ELSE
C          CALL TXCMAP(INTABL,ICOL(6),ICOLP,ISTAT)
C          CALL TBLAI(MADRID(ICOLP),NROWI,DBLONE,DBLONE,IDCAT,1,1)
C      END IF
C
C ***  Perform calculations.
C
      CALL CALCUL(IMF, MADRID(IPNTR), MADRID(JPNTR), NX, NY,
     &            ITOB, IXYU, IARR, RARR, ICOL, NROWI, NCAT,
     &            PMTR, PRCT, MADRID(KPNTR), MADRID(LPNTR), OUTPSF)
C
C *** Free resources.
C
      CALL TDMFRE(LSIZE, LPNTR, ISTAT)
      CALL TDMFRE(KSIZE, KPNTR, ISTAT)
      CALL TDMFRE(JSIZE, JPNTR, ISTAT)
      CALL TBTCLO(ITF, ISTAT)
C
      CALL STSEPI
      END
C
C **********************************************************************
C
      SUBROUTINE TBLAI(ARR, N, START, STEP, NARR, NCOL, ICOL)
C
      IMPLICIT  NONE
C
      REAL       ARR(1)
      INTEGER    N
      INTEGER    NCOL
      DOUBLE PRECISION START
      DOUBLE PRECISION STEP
      INTEGER    NARR(NCOL,N)
      INTEGER    ICOL
C
      INTEGER   L
      DOUBLE PRECISION FCTR
C
      IF (START .EQ. 1.0 .AND. STEP .EQ. 1.0) THEN
         DO 10 L = 1, N
            NARR(ICOL,L) = NINT(ARR(L))
   10    CONTINUE
      ELSE
         FCTR = 1.0 / STEP
         DO 20 L = 1, N
           NARR(ICOL,L) = NINT((ARR(L) - REAL(START))*FCTR) + 1
   20    CONTINUE
      ENDIF
C
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE TBLAR(ARR, N, START, STEP, AARR, NCOL, ICOL)
C
      IMPLICIT       NONE
      INTEGER        N
      INTEGER        NCOL
      REAL           ARR(1)
      DOUBLE PRECISION  START
      DOUBLE PRECISION  STEP
      REAL           AARR(NCOL,N)
      INTEGER        ICOL
C
      INTEGER        L
      REAL           FCTR
C
      IF (START .EQ. 1.0 .AND. STEP .EQ. 1.0) THEN
         DO 10 L = 1, N
            AARR(ICOL,L) = ARR(L)
   10    CONTINUE
      ELSE
         FCTR = 1.0 / REAL(STEP)
         DO 20 L = 1, N
            AARR(ICOL,L) = (ARR(L) - REAL(START))*FCTR + 1.0
   20    CONTINUE
      ENDIF
C
      RETURN
      END