C @(#)fsgrnt.for	17.1.1.1 (ES0-DMD) 01/25/02 17:15:41
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.IDNTIFICATION
C  subroutine FSGRNT         version 1.2       830920
C  A. Kruszewski             ESO Garching
C  modified                  version 1.3       870304
C  A. Kruszewski             Obs. de Geneve
C.KEYWORDS
C  profiles
C.PURPOSE
C  calculates corrections to a standard point spread function
C.ALGORYTHM
C  objects with relative gradient in limits from -0.05 to 0.05
C  are used for improving standart point spread function
C  this subroutine can work efficiently when input point spread
C  function and corresponding relative gradients are sufficiently
C  accurate
C.INPUT/OUTPUT
C  input parameters
C  PRCT        real*4 array      catalog of observed profiles
C  PMTR        real*4 array      objects' parameters
C  M           integer*4         number of catalogued objects
C  KSGR        integer*4         number of improved values of
C  HHCUT       real*4            upper limit of usable profile values
C  TRSH        real*4            limiting treshold
C  CRMD        real*4 array      control parameters for subroutine "MODE
C  SPRF        real*4 array      standard profile
C  output parameters
C  SPRF        real*4 array      standard profile
C-----------------------------------------------------------------------
      SUBROUTINE FSGRNT(L0, L1, LW, NREG, LSTP,
     &                      NP, NCAT, PMTR, PRCT, KSGR,
     &                      HHCUT, TRSH, UPGR, CRMD, SPRF)
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   NP
      INTEGER   NCAT(NIPAR,NP)
      REAL      PMTR(NRPAR,NP)
      REAL      PRCT(0:MAXSUB,NP)
      INTEGER   KSGR
      REAL      HHCUT
      REAL      TRSH
      REAL      UPGR
      REAL      CRMD(3)
      REAL      SPRF(0:MAXSUB)
C
      INTEGER   L, LZ, LL
      INTEGER   K, KK, KKK
      INTEGER   IC
      INTEGER   M
      REAL      CINP(MPSF)
      REAL      CPRF(MPSF,0:MAXSUB)
      REAL      HHHC
      REAL      SIGMA
C     REAL      FCT(MAXSUB)
C
      HHHC = MIN( 5.0*TRSH , 0.05*HHCUT )
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
      M = MAX ( L1 , LW )
      KK = 0
      DO 30 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
C
C ***     Selects objects with proper values
C ***     of relative gradient PMTR(3,*).
C
          IF ( PRCT(0,LZ) .GT. HHHC .AND.
     &                 ABS( PMTR(3,LZ) ) .LT. UPGR ) THEN
C
C ***         Prepare array holding input data CPRF.
C
              IF ( KK .LT. MPSF) THEN
                  KK = KK + 1
                  DO 40 LL = 0 , KSGR
                      CPRF(KK,LL) = PRCT(LL,LZ)
   40             CONTINUE
              ENDIF
          ENDIF
   30 CONTINUE
C
C *** Improve standard profile.
C
      DO 50 L = 1 , KSGR
C
C ***     Put usable data into array CINP.
C
          KKK = 0
          DO 60 K = 1 , KK
              IF ( CPRF(K,L) .GT. 0.0 .AND.
     &                    CPRF(K,L) .LT. HHCUT ) THEN
                  IC = 0
                  LL = 0
   71             CONTINUE
                      IF ( IC .NE. 0 .OR. LL .GE. L ) GOTO 70
                      IF ( CPRF(K,LL) .LT. HHCUT ) THEN
                          IC = 1
                          KKK = KKK + 1
                          CINP(KKK) = LOG10( CPRF(K,LL) / CPRF(K,L) )
                          IF ( LL .GT. 0 ) THEN
                              CINP(KKK) = CINP(KKK)+SPRF(LL)
                          ENDIF
                      ELSE
                          LL=LL+1
                      ENDIF
                      GOTO 71
   70             CONTINUE
              ENDIF
   60     CONTINUE
C
C ***     Calculate improved values of standard profile.
C
          IF ( KKK .GT. 2 ) THEN
              CALL MODE( CINP , KKK , CRMD , SPRF(L) , SIGMA )
          ELSE IF ( KKK .EQ. 2 ) THEN
              SPRF(L) = 0.5*CINP(1) + 0.5*CINP(2)
          ELSE IF ( KKK .EQ. 1 ) THEN
              SPRF(L) = CINP(1)
          ENDIF
   50 CONTINUE
C
      RETURN
C
      END
C