C===========================================================================
C Copyright (C) 1995-2005 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 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence 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
C  subroutine CALCUL         version 2.4       831007
C  A. Kruszewski             ESO Garching
C
C  modified by
C  Ch. Ounnas                ESO - GARCHING    831013
C                                              840523
C                                              840628
C
C  modified for FX           version 2.5       870303
C  A. Kruszewski             Obs. de Geneva
C
C  modified for huge images  version 4.0       880915
C  A. Kruszewski             Warsaw U. Obs.
C
C.KEYWORDS
C
C  classifying parameters, magnitudes, positions, profiles
C
C.PURPOSE
C
C  for an input list of objects it calculates classifying parameters,
C  magnitudes, positions, gradients, sizes
C
C.INPUT/OUTPUT
C
C  input arguments
C
C  IMF         integer*4         image file
C  A           real*4 array      image frame
C  JAPY        integer*4 array   pointers to image lines
C  NX          integer*4         x-dimension of an array A
C  NY          integer*4         y-dimension of an array A
C  ITOB        integer*4 array   limits of objects area
C  IXYU        integer*4 array   limits of used area
C  IARR        integer*4 array   values of integer keywords
C  RARR        real*4 array      values of real keywords
C  ICOL        integer*4 array   positions of special table columns
C  M0          integer           number of objects
C  NCAT        integer*4 array   integer parameters of objects
C  PMTR        real*4 array      real parameters of objects
C  PRCT        real*4 array      catalog of objects profiles
C  FPSF        real*4 array      two-dimensional p.s.f.
C  IPSF        integer*4 array   pointers to FPSF
C 
C.VERSIONS
C 051026	last modif
C 
C-----------------------------------------------------------------------
C 
        SUBROUTINE CALCUL(IMF, A, JAPY, NX, NY, ITOB, IXYU,
     &                    IARR, RARR, ICOL, M0, NCAT, PMTR, PRCT,
     &                    FPSF, IPSF, OUTPSF)
C
        IMPLICIT  NONE
        INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
C
        INTEGER   I, IACT, IADR, IARR(32), IAVDIS
        INTEGER   IBUF(4), ICOL(6), ICT, IDLM, IHED, IMF, IOF
        INTEGER   IPF, IPSF(1), ISTAT, ITOB(4)
        INTEGER   IUSD(4), IVRF, IXYU(4)
        INTEGER   J, JAPY(1)
        INTEGER   K, KNUL, KUN
        INTEGER   L, L0, L1, LACT, LDBG
        INTEGER   LI, LL, LL2, LLZ, LM, LPXL
        INTEGER   LSBP, LSTP(LPBUF), LW, LZ
        INTEGER   M, M0, MAXS, MCM(21), MM
        INTEGER   MADRID(1)
        INTEGER   NACT, NAXISP, NBYTE, NCAT(NIPAR,MAXCNT)
        INTEGER   NCOL, NCNT, NCT(NIPAR), NEL, NROW
        INTEGER   NLPB, NP, NPIXP(2), NPRF
        INTEGER   NREG, NTMP, NVAL, NX, NY
        INTEGER*8  NPNTRP
C
        REAL      ADLM
        REAL      A(1), ABGRD, APSF(0:MAXSUB)
        REAL      DIST
        REAL      FPSF(1), FTMP(2)
        REAL      PMT(NRPAR), PMTR(NRPAR,MAXCNT)
        REAL      PRCT(0:MAXSUB,MAXCNT)
        REAL      RARR(64)
        REAL      STPR(MAXSUB)
        REAL      TRSH
        REAL      XCMP, YCMP
        REAL      XOBJ, YOBJ
        REAL      PRC
C       REAL      DUMP(40000)
C       REAL      TEMP
C
        DOUBLE PRECISION   START(2), STARTP(2), STEP(2), STEPP(2)
C
        CHARACTER*1    TYPE
        CHARACTER*48   CUNIT
        CHARACTER*60   OUTPSF
        CHARACTER*72   IDENT
        CHARACTER*80   OUTPUT
        CHARACTER*60   OUTABL
C
        LOGICAL   DONE, TWOD
C
        INCLUDE   'MID_INCLUDE:ST_DEF.INC/NOLIST'
        COMMON   /VMR/MADRID
        INCLUDE   'MID_INCLUDE:ST_DAT.INC/NOLIST'
C
C *** Recall often used quantities.
C
      NP   = MAXCNT
      LDBG = IARR(1)
      IVRF = IARR(4)
      IHED = IARR(8)
      LPXL = IARR(20)
      LSBP = IARR(21)
      TRSH = RARR(3)
      ADLM = RARR(42)
      IDLM = NINT(RARR(42)) + 1
      IF (LPXL .GT. 0 .OR. LSBP .GT. 0) THEN
         TWOD = .TRUE.
      ELSE
         TWOD = .FALSE.
      ENDIF
      ABGRD = 0.0
      NROW = 100                              !initially allocate 100 rows
C
C ******      Initialize point spread function.
C
      CALL INAPSF(RARR, MAXSUB, APSF)
C
C *** Find number of lines per buffer NLPB.
C
      NLPB = NY
C     NLPB = NIBUF /(IXYU(3) - IXYU(1) + 1)
C
C *** Catalog data is accesible for objects starting
C *** with L0+1 and ending with L1. Last object written
C *** into scratch file is LW.
C
      L0 = 0
      L1 = M0
      LW = 0
C
C *** ICOL(3) .GT. 0  when background column is present.
C *** ICOL(4) .GT. 0  when central intensities are present.
C *** ICOL(5) .GT. 0  when isophotal radii are present.
C *** Abort when there is no coordinate data.
C
      IF (ICOL(1) .EQ. 0 .OR. ICOL(2) .EQ. 0) THEN
          WRITE(OUTPUT,'(A)') 'No coordinate data present'
          CALL STTPUT(OUTPUT, ISTAT)
      ENDIF
C
C *** M0 is an original number of objects. M is number of
C *** objects at loop start. MM is an actual number of
C *** objects, it is updated inside the internal DO WHILE loop.
C *** IBUF define limits of image buffer.
C
      IBUF(1) = 1
      IBUF(2) = 1
      IBUF(3) = NX
      IBUF(4) = NY
C     IBUF(1) = 0
C     IBUF(2) = 0
C     IBUF(3) = 0
C     IBUF(4) = 0
C
C *** Divide analysed area into regions.
C
      CALL DEFLST(LSTP, ITOB, M0, NREG)
C
C *** Initialize linked lists of objects in regions.
C
      CALL INILST(LSTP, ITOB, NREG, NCAT, PMTR, PRCT, M0)
      M       = M0
      MM      = M0
      IF (LDBG .GE. 1) THEN
          WRITE(OUTPUT,'(A,I7,A,I3)')
     &                   'Initial number of objects = ',
     &                   M0, ' Number of iterations = ', IARR(2)
          CALL STTPUT(OUTPUT, ISTAT)
      ENDIF
C
C *** Copy input table data into scratch file.
C
C     CALL PARCPY(ITF, ISF, START, STEP, NICOL, M0,
C    &            ITSTRT, ICOL)
C     LW = M0
C
C *** External loop is repeated IARR(2)+1 times.
C *** Number of current iteration is kept in NCNT.
C
      NCNT = 0
   10 CONTINUE
C
          WRITE (OUTPUT, '(A,I3)') 'Starts iteration', 	NCNT
          CALL STTPUT(OUTPUT, ISTAT)
          NCNT = NCNT + 1
          M = MM
          L = 0
C
C ***     Calculate average separation between objects.
C
          IAVDIS = (ITOB(3)-ITOB(1)+1) * (ITOB(4)-ITOB(2)+1)
          IAVDIS = INT(SQRT(FLOAT(IAVDIS / M)))
C
C ***     Start inner loop.
   20     CONTINUE
C
              L = L + 1
              LM = M / 5
              IF (MOD(L, LM) .EQ. 0) THEN
                  WRITE (OUTPUT,'(I5,A)') L,' objects processed'
                  CALL STTPUT(OUTPUT, ISTAT)
              ENDIF
C
C ***         Check if object is in catalog buffer,
C ***         and swap buffer if necessary.
C
C             IF (L .GT. L1 .OR. L .LE. L0) THEN
C                 CALL PARFIL(ISF, L0, L1, LW, L,LSTP, NREG, NCAT,
C    &                        PMTR, PRCT, NP)
C             ENDIF
C
C ***         Actual pixel position is designed I,J.
C ***         Object number in buffer arrays is LZ.
C
              LZ = L - L0
              I = NCAT(1,LZ)
              J = NCAT(2,LZ)
C
C ***         Fill image buffers if necessary.
C
C              IUSD(1) = MAX(I-IHED, IXYU(1))
C              IUSD(2) = MAX(J-IHED, IXYU(2))
C              IUSD(3) = MIN(I+IHED, IXYU(3))
C              IUSD(4) = MIN(J+IHED, IXYU(4))
C              IF (IUSD(1).LT.IBUF(1) .OR. IUSD(2).LT.IBUF(2) .OR. 
C    2             IUSD(3).GT.IBUF(3) .OR. IUSD(4).GT.IBUF(4)) THEN
C
              IF (L.EQ.1) THEN
                  IUSD(1) = IBUF(1)
                  IUSD(2) = IBUF(2)
                  IUSD(3) = IBUF(3)
                  IUSD(4) = IBUF(4)
                  CALL FILBUF(IMF, A, JAPY,NX,IXYU,IUSD,IBUF)
              ENDIF
C
C ***         Check if object is in investigated area.
C
              IF (I .LT. ITOB(1) .OR. J .LT. ITOB(2) .OR. I .GT.
     &                        ITOB(3) .OR. J .GT. ITOB(4)) THEN
                  PMTR(2,L) = 0.0
                  GOTO 21
              ENDIF
C
              IF (LDBG .GE. 2) THEN
                  OUTPUT = ' '
                  CALL STTPUT(OUTPUT, ISTAT)
                  WRITE(OUTPUT,'(A,I5,A,I5,A,I5)') 'Next object:  ID =',
     2                            L,'    I =', I, '    J =', J
                  CALL STTPUT(OUTPUT, ISTAT)
              ENDIF
C
C ***         Calculate local background if needed.
C
              IF (ICOL(3) .EQ. 0 .AND. NCNT .EQ. 1) THEN
                  CALL SKYMOD(A, JAPY, IBUF, I, J, RARR(39),
     &                        IHED, 0, PMTR(1,LZ))
              ENDIF
C
C ***         Find distance to nearest other object.
C
              CALL NRDIST(L, L0, L1, IAVDIS, NREG, LSTP,
     &                    NCAT, PMTR, PRCT)
C
C ****        Calculate and analyze profile in 8 octants. Results
C ***         are returned in arrays NCAT, PRCT, PMTR and MCM.
C ***         NCAT contain integer parameters, PRCT one-dimensional
C ***         profile, PMTR floating point parameters and MCM
C ***         contain informations about newly found objects.
C
              CALL PRANLZ(A, JAPY, NX, ITOB, IXYU ,
     &                    IBUF, L0, L1, LW, L ,
     &                    M, M0, MM, LSTP, NREG ,
     &                    IARR, RARR, APSF, FPSF, IPSF ,
     &                    NCNT, NCAT, PMTR, PRCT ,
     &                    IAVDIS, MCM)
C
C ***         Check if object is in the frame.
C
              LZ = L - L0
              IF (.NOT.(IVRF .EQ. 0 .AND. L .LE. M0)) THEN
                  I = NINT(PMTR(10,LZ))
                  J = NINT(PMTR(11,LZ))
                  NCAT(1,LZ) = I
                  NCAT(2,LZ) = J
                  IF ((NCNT.GT.IARR(2)) .AND. 
     2                    (I.LT.IARR(12) .OR. I.GT.IARR(14) .OR.
     &                    J.LT.IARR(13) .OR. J .GT. IARR(15))) THEN
                      PMTR(2,LZ) = 0.0
                  ENDIF
                  IF ((NCNT.LE.IARR(2)) .AND. 
     2                    (I.LT.ITOB(1) .OR. I.GT.ITOB(3) .OR.
     &                    J.LT.ITOB(2) .OR. J.GT.ITOB(4))) THEN
                      PMTR(2,LZ) = 0.0
                  ENDIF
              ENDIF
C
C ***         Eliminate fainter components of close blends.
C
              IF (IVRF .EQ. 1 .OR. L .GT. M0) THEN
                  LACT = 0
   51             CONTINUE
                      CALL GETLST(L, L0, L1, IDLM, NREG ,
     &                            LSTP, NCAT, PMTR, PRCT, LACT ,
     &                            NCT, PMT, PRC, DONE)
                      IF (DONE .AND. LACT .LT. L) THEN
C
C ***                     Fetch new component central intensity
C ***                     LL2 and positions XCMP and YCMP.
C
                          LLZ = LACT - L0
                          LL2 = PMTR(2,LLZ)
                          XCMP = PMTR(10,LLZ)
                          YCMP = PMTR(11,LLZ)
C
C ***                     Final check on component distance.
C
                          XOBJ = PMTR(10,LZ)
                          YOBJ = PMTR(11,LZ)
                          DIST = SQRT((XOBJ-XCMP)**2.0 +
     &                                 (YOBJ-YCMP)**2.0)
C
C ***                     Look for another component
C ***                     if that is not close enough.
C
                          IF (DIST .GE. ADLM) GOTO 51
C
C ***                     Do not contest objects that
C ***                     are not to be veryfied.
C
                          IF (IVRF .EQ. 0 .AND. LACT .LE. M0) THEN
C
C ***                         The object with higher number is rejected.
C
                              PMTR(2,LZ) = 0.0
                              GOTO 50
                          ENDIF
C
C ***                     Check which of two objects is brighter.
C
                          IF (PMTR(2,LZ) .LE. LL2) THEN
                              PMTR(2,LZ) = 0.0
                          ELSE
                              PMTR(2,LLZ) = 0.0
                          ENDIF
                          GOTO 51
                      ELSE
                          IF (DONE) GOTO 51
                      ENDIF
   50             CONTINUE
              ENDIF
C
C ***         Calculate additional classifiers.
C
              CALL APPMTR(PRCT(0,LZ), NCAT(5,LZ), IARR(5) ,
     &                     RARR, APSF, PMTR(1,LZ))
C
   21         CONTINUE
          IF (L .LT. MM) GOTO 20
C
          IF (LDBG .GT. 0) THEN
              OUTPUT = ' '
              CALL STTPUT(OUTPUT, ISTAT)
              WRITE (OUTPUT,'(A)') 'PROFILES ANALYSED'
              CALL STTPUT(OUTPUT, ISTAT)
              WRITE (OUTPUT,'(A)') '-----------------'
              CALL STTPUT(OUTPUT, ISTAT)
          ENDIF
C
C ***     Improve one dimensional point spread function
C ***     and calculate relative gradients.
C
          L0 = 0
          L1 = MM
          LW = MM
          CALL PNTSPF(IMF, L0, L1, LW, NREG ,
     &                LSTP, FPSF, NCAT, PMTR, PRCT ,
     &                IARR, RARR, ABGRD)
C
C ***     Initialize two-dimensional psf.
C
          IF (IARR(2).GT.0 .AND. NCNT.EQ.1 .AND.
     2                (LPXL.GT.0 .OR. LSBP.GT.0)) THEN
              NPRF = NOSP + (2*LSBP+1)**2
              CALL DEFPSF(RARR, FPSF, NPRF, IPSF, LPXL, LSBP)
          ENDIF
C
C ***     Modify two-dimensional point spread function.
C
          IF (NCNT.GT.1 .AND. (LPXL.GT.0 .OR. LSBP.GT.0)) THEN
              NPRF = NOSP + (2*LSBP+1)**2
              CALL MODPSF(RARR, FPSF, NPRF, IPSF, LPXL, LSBP)
          ENDIF
C
C ***     Calculate stellar magnitudes by convolving
C ***     one dimensional observed profiles with the
C ***     one dimensional point spread function.
C
          ICT = NCNT - IARR(2)
          CALL PRFCNV(L0, L1, LW, NREG, LSTP ,
     &                NCAT, PMTR, PRCT, IARR, RARR ,
     &                ICT, ABGRD)
C
C ***     Update scratch file.
C
C          IF (L1 .GT. LW) THEN
C              NPP = L1 - L0
C              CALL PARFIL(ISF, L0, L1, LW, L, LSTP,
C    &                 NREG, NCAT, PMTR, PRCT, NPP)
C          ENDIF
C
C ***     Remove objects which are too faint.
C
          CALL RENMBR(L0, L1, LW, NREG, LSTP ,
     &                NCAT, PMTR, PRCT, IVRF, TRSH ,
     &                M0, MM, M)
          MM = M
          WRITE (OUTPUT, '(A,I5)') 'Actual number of objects = ',M
          CALL STTPUT(OUTPUT, ISTAT)
C
C ***     End of external loop.
C
      IF (NCNT .LE. IARR(2)) GOTO 10
C
C *** Write two dimensional psf into descriptor UPROFILE.
C
      IF (TWOD .AND. IARR(2) .GT. 0 .AND. NCNT .GT. IARR(2)) THEN
          IF (OUTPSF .NE. 'NONE') THEN
              NTMP = (2*LPXL+1)*(2*LSBP+1)
              LL = NTMP / 2
              NVAL = NTMP*NTMP
              NAXISP = 2
              NPIXP(1) = NTMP
              NPIXP(2) = NTMP
              STARTP(1) = 1.0
              STARTP(2) = 1.0
              STEPP(1) = 1.0
              STEPP(2) = 1.0
              MAXS = 1
              CALL STDRDC(IMF, 'IDENT', 72, 1, 1 ,
     &                     NACT, IDENT, KUN, KNUL, ISTAT)
              CALL STDRDC(IMF, 'CUNIT', 48, 1, 1 ,
     &                     NACT, CUNIT, KUN, KNUL, ISTAT)
              CALL STIPUT(OUTPSF, D_R4_FORMAT, F_IO_MODE ,
     &                     F_IMA_TYPE, NAXISP, NPIXP, STARTP ,
     &                     STEPP, IDENT, CUNIT, NPNTRP, IPF ,
     &                     ISTAT)
              IADR = 4 * NVAL + 1  
              CALL FDTOTD(FPSF(1), FPSF(IADR), LPXL, LSBP, LL)
              CALL COPYF(FPSF(IADR),MADRID(NPNTRP),NVAL)
              FTMP(1) = -0.1
              FTMP(2) = 1.1
              CALL STDWRR(IPF, 'LHCUTS', FTMP, 1, 2, KUN, ISTAT)
              CALL STFCLO(IPF,ISTAT)
          ENDIF
      ENDIF
C
C *** Display some informations.
C
      IF (LDBG .GE. 1) THEN
         WRITE(OUTPUT,'(A)') 
     2   'Logarithmic differential point spread function'
         CALL STTPUT(OUTPUT, ISTAT)
         WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=14,21)
         CALL STTPUT(OUTPUT, ISTAT)
         WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=22,29)
         CALL STTPUT(OUTPUT, ISTAT)
         WRITE (OUTPUT,'(8F10.3)') (RARR(L),L=30,37)
         CALL STTPUT(OUTPUT, ISTAT)
       ENDIF      
C
      IF (LDBG .GE. 2) THEN
         DO 30 L = 1, M
            I = NCAT(1,L)
            J = NCAT(2,L)
            IF (I .LT. ITOB(1) .OR. J .LT. ITOB(2) .OR. I .GT.
     &                 ITOB(3) .OR. J .GT. ITOB(4)) GOTO 30
            OUTPUT = ' '
            CALL STTPUT(OUTPUT, ISTAT)
            WRITE (OUTPUT,'(A)') '           ID          X          Y'//
     &            ' CLOSEST_N  UNBLENDED  OBJ_SIZE  SATURATED'
            CALL STTPUT(OUTPUT, ISTAT)
            WRITE(OUTPUT,'(7I11)') L, (NCAT(LI,L),LI=1,6)
            CALL STTPUT(OUTPUT, ISTAT)
            IF (LDBG.EQ.2) THEN
               WRITE (OUTPUT,'(A)') '   BACKGRND  CENTRAL_9     '//
     &               'REL_GRAD ISOPHOT_MAG  CNV_MAG  ISOPHOT_RAD'//
     &               '  CLASS'
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3)') PMTR(1,L), PMTR(2,L),
     &               PMTR(3,L), PMTR(5,L), PMTR(12,L),
     &               PMTR(15,L), PMTR(21,L)
               CALL STTPUT(OUTPUT, ISTAT)
            ENDIF
            IF (LDBG .GT. 2) THEN
               WRITE (OUTPUT,'(A)') 'Output parameters'
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3)') PMTR(10,L),PMTR(11,L),
     &               PMTR(12,L),PMTR(13,L),PMTR(20,L),PMTR(3,L),
     &               PMTR(4,L)
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3)') PMTR(1,L),PMTR(2,L),
     &               PMTR(6,L),PMTR(7,L),PMTR(8,L),PMTR(9,L),PMTR(15,L)
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,6G11.3)') PMTR(16,L),PMTR(17,L),
     &              PMTR(18,L),PMTR(19,L),PMTR(5,L),PMTR(21,L)
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,*) 'Pixel spaced average profile'
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=0,6)
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=7,13)
               CALL STTPUT(OUTPUT, ISTAT)
               WRITE(OUTPUT,'(1X,7G11.3,2X)') (PRCT(K,L),K=14,20)
               CALL STTPUT(OUTPUT, ISTAT)
            ENDIF
   30    CONTINUE
      ENDIF
C
C *** Create or update descriptor DPROFILE in an input image
C *** frame containing the used point spread function.
C
      CALL STDFND(IMF, 'DPROFILE', TYPE, NEL, NBYTE, ISTAT)
      IF (TYPE .EQ. 'R' .AND. NEL .GT. 0) THEN
         IF (IARR(11) .NE. 0) THEN
            CALL STDWRR(IMF, 'DPROFILE', RARR(14), 1,
     &                                  ABS(IARR(11)), KUN, ISTAT)
         ENDIF
      ELSE
         CALL STDWRR(IMF, 'DPROFILE', RARR(14), 1, 25, KUN, ISTAT)
      ENDIF
C
C *** Quit if output table is not to be written.
C
      IF (IARR(3) .NE. 1) RETURN
C
C***  Initialize and open output table file.
C 
      CALL STKRDC('OUT_A', 1, 1, 60, IACT, OUTABL, KUN, KNUL, ISTAT)
      IF (IARR(6) .GT. 0) THEN
         NCOL = 27 + MIN(IARR(6), MAXSUB)
      ELSE
         NCOL = 26
      ENDIF
      CALL TBTINI(OUTABL, 0, F_O_MODE, NCOL, NROW, IOF, ISTAT)
      CALL STDRDD(IMF, 'START', 1, 2, IACT, START, KUN, KNUL, ISTAT)
      CALL STDRDD(IMF, 'STEP', 1, 2, IACT, STEP, KUN, KNUL, ISTAT)
      CALL CTABLE(IOF, NCOL, MM, START, STEP, NCAT, PMTR, PRCT, NP)
      CALL STDWRD(IOF, 'START', START, 1, 2, KUN, ISTAT)
      CALL STDWRD(IOF, 'STEP', STEP, 1, 2, KUN, ISTAT) 
C
C *** Write descriptors into output table.
C
      DO 75 K = 1, 25
         STPR(K) = RARR(13+K)
   75 CONTINUE
      DO 76 K = 26, MAXSUB
         STPR(K) = RARR(38)
   76 CONTINUE
      CALL STDWRR(IOF, 'DPROFILE', STPR, 1, MAXSUB, KUN, ISTAT)
C
C ******      Close output table.
C
      CALL TBSINI(IOF, ISTAT)
      CALL TBTCLO(IOF, ISTAT)
C
C
C     DO L=1,M
C        PMTR(12,L)=AMGN(L)+ZRMG
C        ICLS(2,L)=INT(PMTR(21,L))
C     END DO
C
C***********************************************************************
C
C         *****        Two options to choose         *****
C
C      CALL RD_DESCR_R(8,'FLAT_SKY',ABGR,ISTAT)
C
C      CALL GETDSCR_ST(FRAMEA,'FLAT_SKY','REAL',1,8,ABGR,IACT,ISTAT)
C
C      ABGR=1.0            ! If none of options is valid
C
C***********************************************************************
C
C
C displays on terminal screen and writes into log file most important
C informations
C
C      WRITE(OUTPUT,'(1X,A)') FRAMEA
C      CALL STTPUT(OUTPUT, ISTAT)
C      WRITE(OUTPUT,'(1X,A,2F8.2)') 'Low and high cuts = ',RARR(1),
C     +      RARR(2)
C      CALL STTPUT(OUTPUT, ISTAT)
C      WRITE(OUTPUT,'(1X,A,I3)') 'Subarray half-edge = ',IHED
C      CALL STTPUT(OUTPUT, ISTAT)
C      WRITE(OUTPUT,'(1X,A,F5.3)') 'Limiting threshold = ',TRSH
C      CALL STTPUT(OUTPUT, ISTAT)
C      WRITE(OUTPUT,'(1X,A,F7.3)') 'Zero magnitude = ',RARR(11)
C      CALL STTPUT(OUTPUT, ISTAT)
C      WRITE(OUTPUT,'(1X,A,2F8.3)')'Aperture sizes in pixels',RARR(12),
C     +      RARR(54)
C      CALL STTPUT(OUTPUT, ISTAT)
C
C outputs a list of objects with relevant parameters
C
C      IF (LDBG.GE.1) THEN
C         DO L=1,M
C            WRITE (OUTPUT,'(/A)') '      ID          X          Y'//
C     +            '  CLOSEST_N  UNBLENDED   OBJ_SIZE  SATURATED'
C           CALL STTPUT(OUTPUT, ISTAT)
C           WRITE (OUTPUT,'(7I11)') L,(NCAT(LI,L),LI=1,6)
C           CALL STTPUT(OUTPUT, ISTAT)
C           IF (LDBG.EQ.2) THEN
C              WRITE (OUTPUT,'(A)') '    BACKGRND  CENTRAL_9   R_GRADIENT'//
C     +              ' ISOPHOT_MAG  CNV_MAG  ISOPHOT_RAD  CLASS'
C              CALL STTPUT(OUTPUT, ISTAT)
C              WRITE (OUTPUT,'(1X,7F11.3)') PMTR(1,L),PMTR(2,L),
C     +              PMTR(3,L),PMTR(5,L),PMTR(12,L),PMTR(15,L),PMTR(21,L)
C              CALL STTPUT(OUTPUT, ISTAT)
C           END IF
C           IF (LOUT.GT.2) THEN
C               WRITE (OUTPUT,'(A)') 'Output parameters'
C               CALL STTPUT(OUTPUT, ISTAT)
C               WRITE (OUTPUT,'(1X,8F7.3,3F7.1)') (PMTR(K,L),K=1,11)
C               CALL STTPUT(OUTPUT, ISTAT)
C               WRITE (OUTPUT,'(1X,9F7.3,F7.0,F7.1)') (PMTR(K,L),K=12,22)
C               CALL STTPUT(OUTPUT, ISTAT)
C               WRITE (OUTPUT,'(A)') 'Pixel spaced average profile'
C               CALL STTPUT(OUTPUT, ISTAT)
C               WRITE (OUTPUT,'(10F8.3)') (PRCT(K,L),K=0,19)
C               CALL STTPUT(OUTPUT, ISTAT)
C            END IF
C         END DO
C      END IF
C
C ****   Writes output table file.
C
C      IF (LTAB.EQ.1) THEN
C
C ****   Reads needed informations from image
C
C***********************************************************************
C
C         *****         Two options to choose !!!         *****
C
C                  In case of temporary image format
C
C         CALL RD_DESCR_C(8,'IDENT',IDENT,ISTAT)
C         CALL RD_DESCR_R(8,'STARTX',START(1),ISTAT)
C         CALL RD_DESCR_R(8,'STARTY',START(2),ISTAT)
C         CALL RD_DESCR_R(8,'STEPX',STEP(1),ISTAT)
C         CALL RD_DESCR_R(8,'STEPY',STEP(2),ISTAT)
C
C                    In case of Midas image format
C
C         CALL GETDSCR_ST(FRAMEA,'IDENT','CHARACTER',1,72,IACT,IDENT,IS)
C         CALL GETDSCR_ST(FRAMEA,'START','REAL',1,2,IACT,START,ISTAT)
C         CALL GETDSCR_ST(FRAMEA,'STEP','REAL',1,2,IACT,STEP,ISTAT)
C
C***********************************************************************
C
C          *****         Two options to choose          *****
C
C                  In case of temporary table format
C
C         OPEN (11,FILE=TABLE,STATUS='new')
C         ICOL=22+IPRF
C         CALL CRTAB(11,IDENT,START,STEP,PMTR,PRCT,ICOL,M,IDP)
C         write (OUTPUT,*) idp
C         CALL STTPUT(OUTPUT, ISTAT)
C         CALL WRDESR(11,IDP,'FLAT_SKY',1,ABGR,ISTAT)
C         CALL WRDESR(11,IDP,'TRESHOLD',1,TRSH,ISTAT)
C         CALL WRDESI(11,IDP,'HALFEDGE',1,IHED,ISTAT)
C         CALL WRDESR(11,IDP,'STMETRIC',2,STMT,ISTAT)
C         CALL WRDESR(11,IDP,'SPROFILE',25,STPR,ISTAT)
C         IF (MGCR2.EQ.1) THEN
C            CALL WRDESR(11,IDP,'EXPRTIME',1,TINT,ISTAT)
C         END IF
C         CLOSE(11)
C
C                   In case of Midas table format
C
C         CALL CTABLE(TABLE,NCAT,PMTR,PRCT,ICLS,M,START,STEP,IPRF)
C         I1=INDEX(TABLE//' ',' ')-1
C         TABLET=TABLE(1:I1)//'.TBL'
C         CALL PUTDSCR_ST(TABLET,'NORFRAME','CHARACTER',FRAMEA,1,8,
C     +         ISTAT)
C         CALL PUTDSCR_ST(TABLET,'FLAT_SKY','REAL',ABGR,1,1,ISTAT)
C         CALL PUTDSCR_ST(TABLET,'TRESHOLD','REAL',TRSH,1,1,ISTAT)
C         CALL PUTDSCR_ST(TABLET,'HALFEDGE','INTEGER',IHED,1,1,ISTAT)
C         CALL PUTDSCR_ST(TABLET,'ZEROMAGN','REAL',ZRMG,1,1,ISTAT)
C         CALL PUTDSCR_ST(TABLET,'STMETRIC','REAL',STMT,1,2,ISTAT)
C         CALL PUTDSCR_ST(TABLET,'SPROFILE','REAL',STPR,1,25,ISTAT)
C         IF (MGCR2.EQ.1) THEN
C             CALL PUTDSCR_ST(TABLET,'EXPRTIME','REAL',TINT,1,1,ISTAT)
C         END IF
C
C***********************************************************************
C
C      END IF
C
C writes "LHCUTS" descriptor into an output image frame, adjusted
C for inspecting image on DeAnza monitor with lookup table "RAINBOW".
C
C      CUTS(1)=0.7
C      CUTS(2)=3.0
C
C      CALL PUTDSCR_ST(FRAMEA,'LHCUTS','REAL',CUTS,1,2,ISTAT)
C
      RETURN
      END
