C @(#)stgrnt.for	17.1.1.1 (ES0-DMD) 01/25/02 17:15:46
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 STGRNT         version 1.1       830920
C  A. Kruszewski             ESO Garching
C.KEYWORDS
C  profiles
C.PURPOSE
C  updates lowest KSRG values of standart stellar profile "STPR"
C.ALGORYTHM
C  for each annular ring with K<=KSGR the subroutine finds a maximum
C  in histogram of values: LOG10(PRFL(K-1)/PRFL(K)) in a range
C  of values from STPR(K)-0.15 to STPR(K)+0.15.
C  therefore an intial value of standart stellar profile "STPR" should
C  be within 0.15 from its true value for obtaining good results.
C.INPUT/OUTPUT
C  input arguments
C  PRCT        real*4 array      catalog of observed profiles
C  M           integer*4         number of catalogued objects
C  KSGR        integer*4         number of updated values of standard
C                                profile
C  HHCUT       real*4            upper limit for used observed profiles
C  TRSH        real*4            limiting lower treshold
C  CRMD        real*4 array      control parameters for subroutine
C                                "MODE"
C  STPR        real*4 array      standard stellar profile
C  output parameters
C  STPR        real*4 array      standard stellar profile
C-----------------------------------------------------------------------
      SUBROUTINE STGRNT(L0, L1, LW, NREG, LSTP,
     &                  NCAT, PMTR, PRCT, KSGR, HHCUT,
     &                  TRSH, UPGR, CRMD, STPR)
C
      IMPLICIT  NONE
      INCLUDE   'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER   L0
      INTEGER   L1
      INTEGER   LW
      INTEGER   NREG
      INTEGER   LSTP(0:4,0:NREG)
      INTEGER   NCAT(NIPAR,MAXCNT)
      REAL      PMTR(NRPAR,MAXCNT)
      REAL      PRCT(0:MAXSUB,MAXCNT)
      INTEGER   KSGR
      REAL      HHCUT
      REAL      TRSH
      REAL      UPGR
      REAL      CRMD(3)
      REAL      STPR(MAXSUB)
C
      INTEGER   M, MM
      INTEGER   L, LZ	
      INTEGER   K, KK
      INTEGER   ICNT(MAXSUB)
      REAL      HHHC
      REAL      RLPR(MPSF,MAXSUB)
      REAL      SIGMA, SCR
C     REAL      FCT(MAXSUB)
C
C *** M is number of objects.
C
      M = MAX( L1 , LW )
C      MARK = 1
C
C *** Set lower limit of central intensity in used objects.
C
      HHHC = MIN( 0.05*HHCUT , 5.0*TRSH )
C
C *** Prepares array of usable values of local gradient RLPR.
C *** Array ICNT hold number of usable values for each annular ring.
C
c      DO 10 K = 1 , 3
c          FCT(K) = 3.0 * HHHC
c   10 CONTINUE
c      DO 20 K = 4 , MAXSUB
c          FCT(K) = 10.0 * HHHC / FLOAT(K)
c   20 CONTINUE
c      DO 30 K = 1 , MAXSUB
c          ICNT(K)=0
c   30 CONTINUE
      DO 40 L = 1 , M
C          IF ( L .GT. L1 .OR. L .LE. L0 ) THEN
C              IOCOD = -1
C              CALL PARFIL( ISF , L , L0 , L1 , LW ,
C     &                     IOCOD , MARK , NCAT , PMTR , PRCT )
C              MARK = 0
C          ENDIF
          LZ = L - L0
          IF ( PRCT(0,LZ) .GT. HHHC ) THEN
              K = 1
   51         CONTINUE
                  IF ( PRCT(K,LZ) .LE. 0.0 .OR. K .GT. KSGR ) GOTO 50
                  IF ( PRCT(K-1,LZ) .LT. HHCUT ) THEN
                      SCR = ALOG10(PRCT(K-1,LZ)/PRCT(K,LZ))
                      IF ( ABS( SCR-STPR(K) ) .LT. UPGR
     &                               .AND. ICNT(K) .LT. MPSF ) THEN       
                          ICNT(K) = ICNT(K) + 1
                          KK = ICNT(K)
                          RLPR(KK,K) = SCR
                      ENDIF
                  ENDIF
                  K = K + 1
                  GOTO 51
   50         CONTINUE
          ENDIF
   40 CONTINUE
C
C *** Calculate updated values of stellar profile.
C
      DO 60 K = 1 , KSGR
          IF ( ICNT(K) .GT. 3 ) THEN
              MM = ICNT(K)
              CALL MODE( RLPR(1,K) , MM , CRMD , STPR(K) , SIGMA )
          ENDIF
   60 CONTINUE
C
      RETURN
C
      END