C @(#)proone.for	17.1.1.1 (ES0-DMD) 01/25/02 17:17: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
      SUBROUTINE PROONE(TID)
C+++
C---
      IMPLICIT  NONE
      INTEGER   TID
C
      INTEGER   NX
      INTEGER   NDSAT
      INTEGER   IDFS
      PARAMETER (NX=10000)
      PARAMETER (NDSAT=50000)
      PARAMETER (IDFS=1000)
      INTEGER   J, J1, KS, K1, K2, KR1 
      INTEGER   IMX, IMY, LKM, ISTAT
      INTEGER   IGRP
      REAL      PRX, PRY, RAG, FLB, DUM
      LOGICAL   FDX, FDY
      CHARACTER OUTP*60

      REAL      DICI, DICS, RIJ, RISI, SAT, XCEN, YCEN
      REAL      BETA, SIGMA, PR
      REAL      ZMA(NX,3), FON(IDFS)
      REAL      SGL(IDFS)
      REAL      AIN, RAMA, RAME, FONM
      INTEGER   IXW, IYW, IX0, IY0, IM, NCX, NCY, IDX, IDY
      INTEGER   KR, KN
      INTEGER   KSAT, I1, NYM, NY2 
      INTEGER   MTS(NDSAT,4), LN(3)
C
      COMMON    /PRONE/ KR,DICI,DICS,RIJ,ZMA,RISI,IXW,IYW,SGL,FON,
     *                  SAT,XCEN,YCEN,IX0,IY0,IM,NCX,NCY,IDX,IDY,
     *                  AIN,RAMA,RAME,FONM,MTS,KSAT,I1,NYM,LN,
     *                  BETA,SIGMA,KN,PR,NY2
C
      KR=KR+1
      DO 10 J=1,IDX
C      
C *** start procedure 
         PRX = FLOAT(IDX)/FLOAT(NCX)
         PRY = FLOAT(IDY)/FLOAT(NCY)
         IF (PRX-INT(PRX).EQ.0.) THEN
           IMX = (J-1)/INT(PRX)+1
         ELSE
           IMX = (J-1)/PRX+1
         END IF
C
         IF (PRY-INT(PRY).EQ.0.) THEN
            IMY = (KR-1)/INT(PRY)+1
         ELSE
            IMY = (KR-1)/PRY+1
         END IF
         IM  =NCX*(IMY-1)+IMX
C *** end procedure CALCOLA CORONA
C      
         RIJ  = ZMA(J,LN(I1))
         RISI = SGL(IM)+FON(IM)
         IF (RIJ.GE.SAT) THEN
C        
C *** start procedure procedura sature 1
            IF (KSAT.EQ.0) THEN
               KSAT        = KSAT+1
               MTS(KSAT,1) = J
               MTS(KSAT,2) = KR
               MTS(KSAT,3) = J
               MTS(KSAT,4) = 0
            ELSE
               IF (MTS(KSAT,2).EQ.KR.AND.MTS(KSAT,3).EQ.J-1) THEN
                  MTS(KSAT,3)=J
               ELSE
                  KSAT=KSAT+1
                  IF (KSAT.GT.NDSAT) THEN
                     OUTP='*** ERROR: Too many pixels above '//
     2                    'saturation level '
                     CALL STTPUT(OUTP,ISTAT)
                  END IF
                  MTS(KSAT,1) = J
                  MTS(KSAT,2) = KR
                  MTS(KSAT,3) = J
                  MTS(KSAT,4) = 0
               END IF
           END IF
C *** end procedure SATURE 1
C        
        ELSE
           IF (RIJ.GE.RISI) THEN
C          
C *** start procedure R MAX
              KS  = 0
              LKM = 0
              DO 20 K1=I1-1,I1+1
                 IF (K1.GT.0.AND.K1.LE.NYM) THEN
                    DO 30 K2=J-NY2,J+NY2
                       IF (K2.GT.0.AND.K2.LE.IDX) THEN
                          IF (ZMA(K2,LN(K1)).GE.RISI) LKM=LKM+1
                          IF (KS.EQ.0) THEN
                             IF (ZMA(K2,LN(K1)).GT.RIJ) KS=-1
                             IF (ZMA(K2,LN(K1)).EQ.RIJ) THEN
                                IF (K1.NE.I1.OR.K2.NE.J) THEN
                                   IF (K1.LE.I1 .AND. K2.LE.J .OR. 
     *                                 K1.LT.I1 .AND. K2.GT.J) KS=-1
                                END IF
                             END IF
                          END IF
                       END IF
   30               CONTINUE
                 END IF
   20         CONTINUE
C
              IF (LKM.LE.1) KS=-1
              IF (KS.EQ.0) THEN
                 KN  = KN+1
                 RIJ = RIJ-FON(IM)
                 J1  = J+IX0+IXW-2
                 KR1 = KR+IY0+IYW-2
                 IF (BETA.GT.0) THEN
                    RAG = SIGMA*SQRT((AIN/RIJ)**(-1./BETA)-1.)
                 ELSE
                    RAG = SIGMA*SQRT(ALOG(RIJ/AIN)/(4*ALOG(2.)))
                 END IF
                 RAMA = AMAX1(RAMA,RAG)
                 RAME = RAME+RAG
                 FLB  = 0
                 FDX  = J.EQ.1.OR.J.EQ.IDX
                 FDY  = KR.EQ.1.OR.KR.EQ.IDY
                 IF (FDX.OR.FDY) FLB=2
                 IGRP = KN
                 DUM       = 0.0
                 CALL CATTWR(TID,KN,IGRP,FLOAT(J1),FLOAT(KR1),RIJ,
     *                      FON(IM),RAG,FLB,FON(IM),DUM,SIGMA,BETA,SAT,
     *                      AIN,FONM)
              END IF
C          
C *** end procedure R MAX
           END IF
        END IF
   10 CONTINUE
C
      RETURN
      END