C @(#)pntspf.for 17.1.1.1 (ES0-DMD) 01/25/02 17:15:43 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