C @(#)pntspf.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 PNTSPF         version 1         820624
C  A. Kruszewski             ESO Garching
C  modified                  version 1.1       870303
C  A. Kruszewski             Obs. de Geneve
C.KEYWORDS
C  classifying parameters, profiles
C.PURPOSE
C  calculates  standard profile "SPRF" and relative, with respect
C  to standard profile, gradients for a list of objects
C.ALGORITHM
C  an approximate differential standard profile "STPR" is read
C  from keywords "
C  used method depends on a value of keyword "PRFLCTRL" which
C  is stored in variable KSGR
C  when "KSGR" is 0 then approximate profile is not improved
C  when "KSGR" is negative then stars whose coordinates are stored
C  in descriptor "STARS" are used for correcting standard profile
C  when "KSRG" is positive an iterative automatic procedure is used
C  for choosing proper standard stars
C.INPUT/OUTPUT
C  input arguments
C  NCAT        integer*4 array   integer parameters of objects
C  M           integer           number of detected objects
C  PRCT        real*4 array      array holding one-dimensional
C                                profiles for a list of objects
C  PMTR        real*4 array      array holding classifiers for
C                                a list of objects
C  IARR        integer*4 array   values of integer keywords
C  RARR        real*4 array      values of real keywords
C  output arguments
C  PMTR        real*4 array      array holding classifiers
C  SPRF        real*4 array      one dimensional point spread function
C-----------------------------------------------------------------------
      SUBROUTINE PNTSPF ( IMF , L0 , L1 , LW , NREG ,
     &                    LSTP , FPSF , NCAT , PMTR , PRCT ,
     &                    IARR , RARR , ABGRD )
C
      IMPLICIT  NONE
      INCLUDE  'MID_REL_INCL:INVENT.INC/NOLIST'
C
      INTEGER  IMF
      INTEGER  L0 
      INTEGER  L1 
      INTEGER  LW
      INTEGER  NREG
      INTEGER  LSTP(0:4,0:NREG)
      REAL     FPSF(1)
      INTEGER  NCAT(NIPAR,MAXCNT)
      REAL     PMTR(NRPAR,MAXCNT)
      REAL     PRCT(0:MAXSUB,MAXCNT)
      INTEGER  IARR(32)
      REAL     RARR(64)
      REAL     ABGRD
C
      INTEGER  IHED
      INTEGER  KSGR
      INTEGER  K, K1, KK, KKK
      INTEGER  L, LZ
      INTEGER  LDBG
      INTEGER  M
      INTEGER  NM
      INTEGER  NK(MPSF)
      INTEGER  NSTS
      INTEGER  NP
      INTEGER  NCAT1(NIPAR,MPSF)

      REAL     BIAS
      REAL     CRMD(3)
      REAL     HCUT, HHCUT
      REAL     PRCT1(0:MAXSUB,MPSF)
      REAL     PMTR1(NRPAR,MPSF)
      REAL     SPRF(0:MAXSUB)
      REAL     STPR(MAXSUB)
      REAL     TRSH
      REAL     UPGR, UPGR2
C
C ******      Recall values of keywords.
C
      NP = MAXCNT
      LDBG = IARR(1)
      IHED = IARR(8)
      KSGR = IARR(11)
      HCUT = RARR(2)
      TRSH = RARR(3)
      CRMD(1) = RARR(39)
      CRMD(2) = RARR(40)
      CRMD(3) = RARR(41)
      UPGR = RARR(5)
      M = MAX( L1 , LW )
C
C *** Calculate average background ABGRD and
C *** upper limit for useful data HHCUT.
C
      IF ( ABGRD .EQ. 0.0 ) THEN
          CALL AVBGRD( L0 , L1 , PMTR , CRMD , ABGRD )
      ENDIF
      HHCUT = 0.7 * (HCUT-ABGRD)
C
C *** Read one-dimensional point spread function.
C
      K1 = MIN( MAXSUB , 25 )
      DO 10 K = 1 , K1
          STPR(K) = RARR(K+13)
   10 CONTINUE
      DO 20 K= 26 , MAXSUB
          STPR(K) = STPR(K1)
   20 CONTINUE
C
C *** Improve differential logarithmic point
C *** spread function STPR if KSGR .GT. 0.
C
      UPGR2 = 2.0 * UPGR
      IF ( KSGR .GT. 0 ) THEN
          CALL STGRNT( L0 , L1 , LW , NREG , LSTP ,
     &                 NCAT , PMTR , PRCT , KSGR , HHCUT ,
     &                 TRSH , UPGR2 , CRMD , STPR )
      ENDIF
C
C *** Calculate cumalative logarithmic point spread function SPRF.
C
      SPRF(0) = 0.0
      DO 30 K = 1 , MAXSUB
         SPRF(K) = SPRF(K-1) + STPR(K)
   30 CONTINUE
C
C *** Calculate relative gradients.
C
      NM=3
   41 CONTINUE
          IF ( NM .EQ.0 ) GOTO 40
          IF (KSGR.LT.0) THEN
C
C ***         Read descriptor STARS with positions of standard
C ***         stars. NSTS is a number of standard stars. NK
C ***         holds identification numbers of standard stars.
C
              CALL RDCRIN( IMF , NCAT , M , NK , NSTS )
              IF ( NSTS .GT. MPSF ) THEN
                  NSTS = MPSF
              ENDIF
              DO 70 KK = 1 , NSTS
                  K = NK(KK)
                  PMTR1(3,KK) = 0.0
                  DO 80 L = 0 , MAXSUB
                      PRCT1(L,KK) = PRCT(L,K)
   80             CONTINUE
   70         CONTINUE
C
C ***         Improve standard profile with help of standard stars.
C
              KKK = -KSGR
              CALL FSGRNT ( L0 , L1 , LW , NREG , LSTP ,
     &                      NSTS , NCAT1 , PMTR1 , PRCT1 , KKK ,
     &                      HHCUT ,TRSH , UPGR2 , CRMD , SPRF )
              NM=1
          ENDIF
          DO 50 L = 1 , M
c                  IF ( L .GT. L1 .OR. L .LE. L0 ) THEN
c                        CALL PARFIL ( ISF , L0 , L1 , LW ,
c     &                              L , LSTP , NREG , NCAT ,
c     &                                    PMTR , PRCT , NP )
c                       ENDIF
              LZ = L - L0
C
C ***         Calculate relative gradients. 
C
              CALL RLGRNT( PRCT(0,LZ) , SPRF , HHCUT , TRSH ,
     &                              PMTR(3,LZ) , PMTR(4,LZ) )
              BIAS = EXP( -(PMTR(25,LZ)**2.0) ) * ( 0.3 - STPR(1) )
              IF ( PMTR(3,LZ) .NE. -1.0 ) THEN
                  PMTR(3,LZ) = PMTR(3,LZ) - BIAS
              ENDIF
C
C ***         Mark stellar objects.
C
              IF ( ABS( PMTR(3,LZ) ) .LT. UPGR .AND. PMTR(4,LZ)
     &                                    .LT. UPGR2 ) THEN
                  PMTR(21,LZ) = 1.0
              ELSE
                  PMTR(21,LZ) = 0.0
              ENDIF
   50     CONTINUE
          IF ( NM .GE. 2 ) THEN
              IF ( KSGR .GT. 0 ) THEN
C
C ***             Improve standard profile in an automatic way.
C
                  CALL FSGRNT( L0 , L1 , LW , NREG , LSTP ,
     &                         M , NCAT , PMTR , PRCT , KSGR ,
     &                         HHCUT , TRSH , UPGR , CRMD , SPRF )
              ELSE
                  NM = 1
              ENDIF
          ENDIF
          NM = NM - 1
          GOTO 41
   40 CONTINUE
C
C ******      Write back improved one-dimensionl standard profile.
C
      K1 = ABS(KSGR)
      DO 60 K = 1 , K1
          RARR(K+13) = SPRF(K) - SPRF(K-1)
   60 CONTINUE
C
      RETURN
C
      END
C
