C @(#)pranlz.for	19.1 (ES0-DMD) 02/25/03 13:25:37
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  subroutine PRANLZ         version 2.7       830922
C  A. Kruszewski             ESO Garching
C  modified for FX           version 2.9       870315
C  A. Kruszewski             Obs. de Geneve
C  modified for MSDOS        version 4.0       880626
C  A. Kruszewski             Warsaw U. Obs.
C.KEYWORDS
C  profiles positions classifiers
C.PURPOSE
C  this subroutine calculates at first an image profile in eight
C  octants. it removes contributions from blended objects and
C  uses a cleaned profile for calculating corrections to the position,
C  elongations, position angle
C.INPUT/OUTPUT
C  input arguments
C  A         real*4 array        image frame
C  N1        integer*4 array     x-dimension of an array A
C  N2        integer*4           y-dimension of an array
C  ID        integer*4           object identification number
C  M         integer*4           number of objects at start of approximation
C  M0        integer*4           initial number of objects
C  MM        integer*4           actuall number of objects
C  IARR      integer*4 array     integer values of keywords
C  RARR      real*4 array        real values of keywords
C  NPAS      integer*4           number of iteration
C  NCAT      integer*4 array     array with integer parameters
C  PRCT      real*4 array        array with one-dimensional profiles
C  PMTR      real*4 array        array holding classifiers
C  output arguments
C  MM        integer*4           actuall number of objects
C  NCAT      integer*4 array     array with integer parameters
C  PRCT      real*4 array        array with one-dimensional profiles
C  PMTR      real*4 array        array holding classifiers
C  MCM       integer*4 array     array holding informations about
C-----------------------------------------------------------------------
      SUBROUTINE PRANLZ(A, JAPY, NX, ITOB, IXYU,
     &                  IBUF, L0, L1, LW, ID,
     &                  M, M0, MM , LSTP, NREG,
     &                  IARR, RARR, APSF, FPSF, IPSF,
     &                  NPAS, NCAT, PMTR, PRCT,
     &                  IAVDIS, MCM)
C
      IMPLICIT  NONE
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER   NREG
      INTEGER   I , IARR(32) , IAVDIS , IAVR(0:MAXSUB)
      INTEGER   IBUF(4) , IBUFS(4) , IC , ICNT(8,0:MAXSUB)
      INTEGER   ID , IDB , IDIF , IDLM , IHED , IK
      INTEGER   IPSF(1) , ISOP , ITT , ITOB(4) , IVRF , IXYU(4)
      INTEGER   J , JAPY(1) , JAPYS(2*MAXSUB+1) , JHED , JK
      INTEGER   K , KM , KMM , KN
      INTEGER   L0 , L1 , LDBG , LHED , LIM , LIM1 , LPXL
      INTEGER   LSBP , LSTP(0:4,0:NREG) , LW , LZ
      INTEGER   MAS((2*MAXSUB+1)**2)
      INTEGER   M , M0 , MCM(21) , MCM0(21) , MM , MN , MS1
      INTEGER   NCAT(NIPAR,MAXCNT) , NCT(NIPAR)
      INTEGER   NPAS, NPXL(0:MAXSUB) , NX
C     INTEGER   NP
C
      INTEGER   LHED0
      INTEGER   KHED
      INTEGER   LN
      INTEGER   II
      INTEGER   IOPC
C     INTEGER   IUSD(4)
C
      REAL      FLTR
      REAL      SIG
      REAL      SCALE
      REAL      CINT2
      REAL      A(1) , ADLM , APSF(0:MAXSUB)
      REAL      AS((2*MAXSUB+1)**2) , AVPR(0:MAXSUB)
      REAL      BGRD , CTRL(3) , DNEB , FPSF(1) , HCUT
      REAL      PMT(NRPAR) , PMTR(NRPAR,MAXCNT) , PRFL(8,0:MAXSUB)
      REAL      PRC(0:MAXSUB) , PRCT(0:MAXSUB,MAXCNT) , RARR(64)
      REAL      STMT, TRSH
      REAL      ZRMG
C
      LOGICAL   TWOD , GOOD
C
      DATA NPXL/1,8,12,16,32,28,40,40,48,68,56,72,68,88,88,84,112,
     &            112,112,116,112,144,140,144,144,168,164,160,184,172,
     &            200,192,188,208,224,224,228,224,248,236,264,248,264,
     &            276,264,288,276,304,304,312,316/
      MS1 = MAXSUB + 1
C
C ******      Restore values of keywords.
C
      LZ = ID - L0
      I = NCAT(1,LZ)
      J = NCAT(2,LZ)
      BGRD = PMTR(1,LZ)
      LDBG = IARR(1)
      IVRF = IARR(4)
      ISOP = IARR(5)
      IHED = IARR(8)
      JHED = IHED/2
      LPXL = IARR(20)
      LSBP = IARR(21)
      HCUT = RARR(2)
      TRSH = RARR(3)
      FLTR = RARR(4)
      ZRMG = RARR(11)
      STMT = RARR(12)
      CTRL(1) = RARR(39)
      CTRL(2) = RARR(40)
      CTRL(3) = RARR(41)
      ADLM = RARR(42)
      IDLM = NINT(ADLM)
      DNEB = RARR(52)
      ITT = IARR(2) + 1
      IF ( LPXL .GT. 0 .AND. LSBP .GT. 0 ) THEN
            TWOD = .TRUE.
      ELSE
            TWOD = .FALSE.
      ENDIF
C
C ******      NCAT(5,LZ) - object size.
C
      LIM = NCAT(5,LZ)
C
C ******      Most of this subroutine body may be repeated up to
C ******      4 times in a DO WHILE loop. The condition for
C ******      terminating the loop is that the image size is
C ******      sufficiently small in comparison with used subarray.
C ******      On each repeatition the size of subarray is increased.
C ******      Index variable IC controls the loop.
C
      IC = 0
      LHED = MIN( MAXSUB , MAX( IHED , LIM+5 ) )
      LHED0 = LHED
C
C ******      Main loop start here.
C
   10      CONTINUE
C
C ******          Fill image buffer if necessary.
C
c            IUSD(1) = MAX( I-LHED , IXYU(1) )
c            IUSD(2) = MAX( J-LHED , IXYU(2) )
c            IUSD(3) = MIN( I+LHED , IXYU(3) )
c            IUSD(4) = MIN( J-LHED , IXYU(4) )
c            IF ( IUSD(1) .LT. IBUF(1) .OR. IUSD(2) .LT.
c     &                        IBUF(2)      .OR. IUSD(3) .GT. IBUF(3)
c     &                              .OR. IUSD(4) .GT. IBUF(4) ) THEN
c                       CALL FILBUF( IMF , MSF , A , MA , JAPY , NX ,
c     &                                    IXYU , IUSD , IBUF )
c                 ENDIF
C
C ***     Mark saturated and bad pixels.
C
          CALL SATBAD( A , JAPY , IBUF , I , J , LHED , RARR , MAS )
C
C ******          Subtract components if not first pass.
C
          IF ( NPAS .GT. 1 ) THEN
              CALL CMPSUB( A , JAPY , IBUF , I , J ,
     &                     L0 , L1 , LW , ID , MM ,
     &                     NREG , LSTP , LHED , TRSH , APSF ,
     &                     FPSF , IPSF , LPXL , LSBP , NCAT ,
     &                     PMTR , PRCT , NPAS , AS , JAPYS ,
     &                     IBUFS , HCUT , MAS )
          END IF
C
C ***     Calculates local background when necessary.
C
          IF ( NPAS .EQ. 1 .AND. LHED .GT. LHED0 ) THEN
              CALL SKYMOD( A , JAPY , IBUF , I , J ,
     &                     CTRL , LHED , 0 , BGRD )
              PMTR(1,LZ) = BGRD
          ELSE IF ( NPAS .GT. 1 ) THEN
            CALL SKYMOD( AS , JAPYS , IBUFS , 0 , 0 ,
     &                   CTRL , LHED , 0 , BGRD )
            PMTR(1,LZ) = BGRD
          ENDIF
C
C ***     Calculate profile in eight octants PRFL.
C
          IF ( NPAS .GT. 1 ) THEN
              CALL PROFIL( AS , MAS , JAPYS , IBUFS , 0 ,
     &                     0 , LHED , LDBG , BGRD , HCUT ,
     &                     PRFL , ICNT )
          ELSE
              CALL PROFIL( A , MAS , JAPY , IBUF , I ,
     &                     J , LHED , LDBG , BGRD , HCUT ,
     &                     PRFL , ICNT )
          ENDIF
          CALL RLBIAS( PRFL , ICNT , PMTR(25,LZ) )
C
C ***     Calculate averaged over octants profile AVPR
C ***     and a number of significant profile rings LIM.
C
          CALL AVERPR( LHED , PRFL , TRSH , ICNT , AVPR ,
     &                 IAVR , NCAT(4,LZ) , NCAT(6,LZ) , LIM )
C
C ***     Clean the profile from influence of other objects.
C
          IDIF = MIN( NCAT(3,LZ) , IAVDIS )
          IF ( NPAS .EQ. 1 .AND. IARR(2) .GT. 0 ) THEN
              KHED = LHED
          ELSE
              KHED = LIM
          ENDIF
          CALL PRFLCL( PRFL , ICNT , AVPR , IAVR , KHED , BGRD , IDIF ,
     &                 LDBG , RARR , MCM0 , NCAT(4,LZ) , NCAT(6,LZ) )
C   
C ***     Update average profile AVPR and image size LIM.
C
          IF ( NCAT(4,LZ) .LT. LIM ) THEN
              CALL AVERPR( LHED , PRFL , TRSH , ICNT , AVPR ,
     &                     IAVR , NCAT(4,LZ) , NCAT(6,LZ) , LIM )
          ENDIF
          CALL INTDET( AVPR , IAVR , APSF , LIM , PMTR(2,LZ) )
C
C ***     Check if average profile goes down sufficiently fast.
C
          IF ( DNEB .GT. 0.0 ) THEN
              CALL PRFLCH( AVPR , LHED , NCAT(6,ID) , HCUT , APSF ,
     &                                          DNEB , LIM )
          ENDIF
C
C ***     Check if an image is sufficiently small
C ***     and enlarge subarray LHED when necessary.
C
          IF ( ( ( LIM .GE. LHED-2 ) .OR. ( LIM .GT. LHED-5 .AND.
     &                  AVPR(0) .GT. (HCUT-BGRD)/2.0 ) ) .AND.
     &                  LHED .LT. MAXSUB .AND. IC .LE. 2 ) THEN
C
              LHED = MIN( MAXSUB , 2*LIM )
              IC = IC + 1
          ELSE
              IC = 3
          ENDIF
          IC = IC + 1
C
C ***     Main loop end here.
C
      IF ( IC .LE. 3 ) GOTO 10
C
C **  Update entry for local background.
C
      PMTR(1,LZ) = BGRD
C
C *** Transform relative coordinates of newly found components
C *** into absolute pixel coordinates IK and JK. Form new
C *** array MCM holding informations about new objects
C
      IF ( .NOT. ( IVRF .EQ. 0 .AND. IARR(2) .EQ. 0 ) ) THEN
          KMM = 0
          DO 20 MN = 1 , 21
              MCM(MN) = 0
   20     CONTINUE
          KM = MCM0(1)
          DO 30 KN = 1 , KM
              IF ( NPAS .GT. 1 ) THEN
                  CALL CPCNTR( AS , JAPYS , IBUFS , 0 , 0 ,
     &                         MCM0(2*KN) , MCM0(2*KN+1) , IK , JK )
                  CALL IFGOOD( AS , JAPYS , IBUFS , MAS , 0 ,
     &                         0 , IK , JK , BGRD , FLTR ,
     &                         TRSH , GOOD )
                  IF ( .NOT. GOOD ) GOTO 30
                  IK = IK + I 
                  JK = JK + J
              ELSE
                  CALL CPCNTR( A , JAPY , IBUF , I , J , MCM0(2*KN) ,
     &                                    MCM0(2*KN+1) , IK , JK )
                  CALL IFGOOD( A ,JAPY , IBUF , MAS , I ,
     &                         J , IK , JK , BGRD , FLTR ,
     &                         TRSH , GOOD )
                  IF ( .NOT. GOOD ) GOTO 30
              ENDIF
              IDB = MIN( IK-ITOB(1) , ITOB(3)-IK ,
     &                              JK-ITOB(2) , ITOB(4)-JK )
              IF ( IDB .GE. JHED .AND. KMM .LT. 10 ) THEN
                  KMM = KMM + 1
                  MCM(2*KMM) = IK
                  MCM(2*KMM+1) = JK
              ENDIF
   30     CONTINUE
          MCM(1) = KMM
      ENDIF
C
C ******      Calculate image parameters.
C
      CALL FPPMTR( PRFL , ICNT , AVPR , IAVR , LHED ,
     &             LIM , NCAT(4,LZ) , NCAT(6,LZ) , ID , L0 ,
     &             TRSH , IVRF , M0 , ITT , NPAS ,
     &             NCAT , PMTR )
      DO 40 K = 0 , LIM
          PRCT(K,LZ) = AVPR(K)
   40 CONTINUE
          LIM1 = LIM + 1
      DO 50 K = LIM1 , MAXSUB
          PRCT(K,LZ) = 0.0
   50 CONTINUE
      NCAT(5,LZ) = LIM
C
C *** Calculate accurate position, evaluate contribution
C *** of central part to convolved magnitude, store data on
C *** corrections to two-dimensional point spread function.
C
      IF ( ( LPXL .GT. 0 .OR. LSBP .GT. 0 ) .AND. NPAS .GT. 1 ) THEN
          IF ( NCAT(10,LZ) .GT. 0 ) THEN
              LN = NCAT(10,LZ) - L0
              DO 60 II = 1 , NIPAR
                  NCT(II) = NCAT(II,LN)
   60         CONTINUE
              DO 70 II = 1 , NRPAR
                  PMT(II) = PMTR(II,LN)
   70         CONTINUE
              DO 80 II = 0 , MAXSUB
                  PRC(II) = PRCT(II,LN)
   80         CONTINUE
          ENDIF
          CALL TWODIM( AS , MAS , JAPYS , IBUFS , LZ ,
     &                 APSF , FPSF , IPSF , NCAT , PMTR ,
     &                 PRCT , NCT , PMT , PRC , IARR ,
     &                 RARR , SIG )
C
C ***     Subtract the object.
C
          IOPC = -1
          CALL STARSA( IOPC , AS , JAPYS , IBUFS , I ,
     &                 J , LPXL , LSBP , NCAT(1,LZ) , PMTR(1,LZ) ,
     &                 PRCT(0,LZ) , APSF , FPSF , 3 , SCALE ,
     &                 CINT2 )
C
C ***     Subtract the brightest stellar component if necessary.
C
          IF ( NCAT(10,LZ) .GT. 0 ) THEN
              CALL STARSA( IOPC , AS , JAPYS , IBUFS , I ,
     &                     J , LPXL , LSBP , NCT , PMT ,
     &                     PRC , APSF , FPSF , 3 , SCALE ,
     &                     CINT2 )
          ENDIF
          IF ( LDBG .GE. 3 ) THEN
              CALL PROFIL( AS , MAS , JAPYS , IBUFS , 0 ,
     &                     0 , LHED , LDBG , BGRD , HCUT ,
     &                     PRFL , ICNT )
          ENDIF
C
C ***     Search for additional faint objects.
C
          CALL SRHNEW( AS , MAS , JAPYS , IBUFS , LHED ,
     &                 I , J , TRSH , FLTR , BGRD ,
     &                 SIG , MCM )
      ENDIF
C
C *** Record newly found objects.
C
      IF ( ID .LE. M .AND. ( .NOT. ( IVRF .EQ. 0 .AND.
     &                              IARR(2) .EQ. 0 ) ) ) THEN
          IF ( NPAS .GT. 1 .AND. NPAS .LE. IARR(2) ) THEN
              CALL NEWOBJ( AS , JAPYS , IBUFS , 0 , 0 ,
     &                     NREG , LSTP , NCAT , PMTR , PRCT ,
     &                     ID , L0 , L1 , LW , MM ,
     &                     TRSH , ADLM , MCM )
          ELSE IF ( NPAS .EQ. 1 ) THEN
              CALL NEWOBJ( A , JAPY , IBUF , I , J ,
     &                     NREG , LSTP , NCAT , PMTR , PRCT ,
     &                     ID , L0 , L1 , LW , MM ,
     &                     TRSH , ADLM , MCM )
          ENDIF
      ENDIF
C
      RETURN
C
      END

