C @(#)pranlz.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 PRANLZ version 2.7 830922 C A. Kruszewski ESO Garching C modified for FX version 2.9 870315 C A. Kruszewski Obs. de Geneve C modified for MSDOS version 4.0 880626 C A. Kruszewski Warsaw U. Obs. C.KEYWORDS C profiles positions classifiers C.PURPOSE C this subroutine calculates at first an image profile in eight C octants. it removes contributions from blended objects and C uses a cleaned profile for calculating corrections to the position, C elongations, position angle C.INPUT/OUTPUT C input arguments C A real*4 array image frame C N1 integer*4 array x-dimension of an array A C N2 integer*4 y-dimension of an array C ID integer*4 object identification number C M integer*4 number of objects at start of approximation C M0 integer*4 initial number of objects C MM integer*4 actuall number of objects C IARR integer*4 array integer values of keywords C RARR real*4 array real values of keywords C NPAS integer*4 number of iteration C NCAT integer*4 array array with integer parameters C PRCT real*4 array array with one-dimensional profiles C PMTR real*4 array array holding classifiers C output arguments C MM integer*4 actuall number of objects C NCAT integer*4 array array with integer parameters C PRCT real*4 array array with one-dimensional profiles C PMTR real*4 array array holding classifiers C MCM integer*4 array array holding informations about C----------------------------------------------------------------------- SUBROUTINE PRANLZ(A, JAPY, NX, ITOB, IXYU, & IBUF, L0, L1, LW, ID, & M, M0, MM , LSTP, NREG, & IARR, RARR, APSF, FPSF, IPSF, & NPAS, NCAT, PMTR, PRCT, & IAVDIS, MCM) C IMPLICIT NONE INCLUDE 'MID_REL_INCL:INVENT.INC/NOLIST' C INTEGER NREG INTEGER I , IARR(32) , IAVDIS , IAVR(0:MAXSUB) INTEGER IBUF(4) , IBUFS(4) , IC , ICNT(8,0:MAXSUB) INTEGER ID , IDB , IDIF , IDLM , IHED , IK INTEGER IPSF(1) , ISOP , ITT , ITOB(4) , IVRF , IXYU(4) INTEGER J , JAPY(1) , JAPYS(2*MAXSUB+1) , JHED , JK INTEGER K , KM , KMM , KN INTEGER L0 , L1 , LDBG , LHED , LIM , LIM1 , LPXL INTEGER LSBP , LSTP(0:4,0:NREG) , LW , LZ INTEGER MAS((2*MAXSUB+1)**2) INTEGER M , M0 , MCM(21) , MCM0(21) , MM , MN , MS1 INTEGER NCAT(NIPAR,MAXCNT) , NCT(NIPAR) INTEGER NPAS, NPXL(0:MAXSUB) , NX C INTEGER NP C INTEGER LHED0 INTEGER KHED INTEGER LN INTEGER II INTEGER IOPC C INTEGER IUSD(4) C REAL FLTR REAL SIG REAL SCALE REAL CINT2 REAL A(1) , ADLM , APSF(0:MAXSUB) REAL AS((2*MAXSUB+1)**2) , AVPR(0:MAXSUB) REAL BGRD , CTRL(3) , DNEB , FPSF(1) , HCUT REAL PMT(NRPAR) , PMTR(NRPAR,MAXCNT) , PRFL(8,0:MAXSUB) REAL PRC(0:MAXSUB) , PRCT(0:MAXSUB,MAXCNT) , RARR(64) REAL STMT, TRSH REAL ZRMG C LOGICAL TWOD , GOOD C DATA NPXL/1,8,12,16,32,28,40,40,48,68,56,72,68,88,88,84,112, & 112,112,116,112,144,140,144,144,168,164,160,184,172, & 200,192,188,208,224,224,228,224,248,236,264,248,264, & 276,264,288,276,304,304,312,316/ MS1 = MAXSUB + 1 C C ****** Restore values of keywords. C LZ = ID - L0 I = NCAT(1,LZ) J = NCAT(2,LZ) BGRD = PMTR(1,LZ) LDBG = IARR(1) IVRF = IARR(4) ISOP = IARR(5) IHED = IARR(8) JHED = IHED/2 LPXL = IARR(20) LSBP = IARR(21) HCUT = RARR(2) TRSH = RARR(3) FLTR = RARR(4) ZRMG = RARR(11) STMT = RARR(12) CTRL(1) = RARR(39) CTRL(2) = RARR(40) CTRL(3) = RARR(41) ADLM = RARR(42) IDLM = NINT(ADLM) DNEB = RARR(52) ITT = IARR(2) + 1 IF ( LPXL .GT. 0 .AND. LSBP .GT. 0 ) THEN TWOD = .TRUE. ELSE TWOD = .FALSE. ENDIF C C ****** NCAT(5,LZ) - object size. C LIM = NCAT(5,LZ) C C ****** Most of this subroutine body may be repeated up to C ****** 4 times in a DO WHILE loop. The condition for C ****** terminating the loop is that the image size is C ****** sufficiently small in comparison with used subarray. C ****** On each repeatition the size of subarray is increased. C ****** Index variable IC controls the loop. C IC = 0 LHED = MIN( MAXSUB , MAX( IHED , LIM+5 ) ) LHED0 = LHED C C ****** Main loop start here. C 10 CONTINUE C C ****** Fill image buffer if necessary. C c IUSD(1) = MAX( I-LHED , IXYU(1) ) c IUSD(2) = MAX( J-LHED , IXYU(2) ) c IUSD(3) = MIN( I+LHED , IXYU(3) ) c IUSD(4) = MIN( J-LHED , IXYU(4) ) c IF ( IUSD(1) .LT. IBUF(1) .OR. IUSD(2) .LT. c & IBUF(2) .OR. IUSD(3) .GT. IBUF(3) c & .OR. IUSD(4) .GT. IBUF(4) ) THEN c CALL FILBUF( IMF , MSF , A , MA , JAPY , NX , c & IXYU , IUSD , IBUF ) c ENDIF C C *** Mark saturated and bad pixels. C CALL SATBAD( A , JAPY , IBUF , I , J , LHED , RARR , MAS ) C C ****** Subtract components if not first pass. C IF ( NPAS .GT. 1 ) THEN CALL CMPSUB( A , JAPY , IBUF , I , J , & L0 , L1 , LW , ID , MM , & NREG , LSTP , LHED , TRSH , APSF , & FPSF , IPSF , LPXL , LSBP , NCAT , & PMTR , PRCT , NPAS , AS , JAPYS , & IBUFS , HCUT , MAS ) END IF C C *** Calculates local background when necessary. C IF ( NPAS .EQ. 1 .AND. LHED .GT. LHED0 ) THEN CALL SKYMOD( A , JAPY , IBUF , I , J , & CTRL , LHED , 0 , BGRD ) PMTR(1,LZ) = BGRD ELSE IF ( NPAS .GT. 1 ) THEN CALL SKYMOD( AS , JAPYS , IBUFS , 0 , 0 , & CTRL , LHED , 0 , BGRD ) PMTR(1,LZ) = BGRD ENDIF C C *** Calculate profile in eight octants PRFL. C IF ( NPAS .GT. 1 ) THEN CALL PROFIL( AS , MAS , JAPYS , IBUFS , 0 , & 0 , LHED , LDBG , BGRD , HCUT , & PRFL , ICNT ) ELSE CALL PROFIL( A , MAS , JAPY , IBUF , I , & J , LHED , LDBG , BGRD , HCUT , & PRFL , ICNT ) ENDIF CALL RLBIAS( PRFL , ICNT , PMTR(25,LZ) ) C C *** Calculate averaged over octants profile AVPR C *** and a number of significant profile rings LIM. C CALL AVERPR( LHED , PRFL , TRSH , ICNT , AVPR , & IAVR , NCAT(4,LZ) , NCAT(6,LZ) , LIM ) C C *** Clean the profile from influence of other objects. C IDIF = MIN( NCAT(3,LZ) , IAVDIS ) IF ( NPAS .EQ. 1 .AND. IARR(2) .GT. 0 ) THEN KHED = LHED ELSE KHED = LIM ENDIF CALL PRFLCL( PRFL , ICNT , AVPR , IAVR , KHED , BGRD , IDIF , & LDBG , RARR , MCM0 , NCAT(4,LZ) , NCAT(6,LZ) ) C C *** Update average profile AVPR and image size LIM. C IF ( NCAT(4,LZ) .LT. LIM ) THEN CALL AVERPR( LHED , PRFL , TRSH , ICNT , AVPR , & IAVR , NCAT(4,LZ) , NCAT(6,LZ) , LIM ) ENDIF CALL INTDET( AVPR , IAVR , APSF , LIM , PMTR(2,LZ) ) C C *** Check if average profile goes down sufficiently fast. C IF ( DNEB .GT. 0.0 ) THEN CALL PRFLCH( AVPR , LHED , NCAT(6,ID) , HCUT , APSF , & DNEB , LIM ) ENDIF C C *** Check if an image is sufficiently small C *** and enlarge subarray LHED when necessary. C IF ( ( ( LIM .GE. LHED-2 ) .OR. ( LIM .GT. LHED-5 .AND. & AVPR(0) .GT. (HCUT-BGRD)/2.0 ) ) .AND. & LHED .LT. MAXSUB .AND. IC .LE. 2 ) THEN C LHED = MIN( MAXSUB , 2*LIM ) IC = IC + 1 ELSE IC = 3 ENDIF IC = IC + 1 C C *** Main loop end here. C IF ( IC .LE. 3 ) GOTO 10 C C ** Update entry for local background. C PMTR(1,LZ) = BGRD C C *** Transform relative coordinates of newly found components C *** into absolute pixel coordinates IK and JK. Form new C *** array MCM holding informations about new objects C IF ( .NOT. ( IVRF .EQ. 0 .AND. IARR(2) .EQ. 0 ) ) THEN KMM = 0 DO 20 MN = 1 , 21 MCM(MN) = 0 20 CONTINUE KM = MCM0(1) DO 30 KN = 1 , KM IF ( NPAS .GT. 1 ) THEN CALL CPCNTR( AS , JAPYS , IBUFS , 0 , 0 , & MCM0(2*KN) , MCM0(2*KN+1) , IK , JK ) CALL IFGOOD( AS , JAPYS , IBUFS , MAS , 0 , & 0 , IK , JK , BGRD , FLTR , & TRSH , GOOD ) IF ( .NOT. GOOD ) GOTO 30 IK = IK + I JK = JK + J ELSE CALL CPCNTR( A , JAPY , IBUF , I , J , MCM0(2*KN) , & MCM0(2*KN+1) , IK , JK ) CALL IFGOOD( A ,JAPY , IBUF , MAS , I , & J , IK , JK , BGRD , FLTR , & TRSH , GOOD ) IF ( .NOT. GOOD ) GOTO 30 ENDIF IDB = MIN( IK-ITOB(1) , ITOB(3)-IK , & JK-ITOB(2) , ITOB(4)-JK ) IF ( IDB .GE. JHED .AND. KMM .LT. 10 ) THEN KMM = KMM + 1 MCM(2*KMM) = IK MCM(2*KMM+1) = JK ENDIF 30 CONTINUE MCM(1) = KMM ENDIF C C ****** Calculate image parameters. C CALL FPPMTR( PRFL , ICNT , AVPR , IAVR , LHED , & LIM , NCAT(4,LZ) , NCAT(6,LZ) , ID , L0 , & TRSH , IVRF , M0 , ITT , NPAS , & NCAT , PMTR ) DO 40 K = 0 , LIM PRCT(K,LZ) = AVPR(K) 40 CONTINUE LIM1 = LIM + 1 DO 50 K = LIM1 , MAXSUB PRCT(K,LZ) = 0.0 50 CONTINUE NCAT(5,LZ) = LIM C C *** Calculate accurate position, evaluate contribution C *** of central part to convolved magnitude, store data on C *** corrections to two-dimensional point spread function. C IF ( ( LPXL .GT. 0 .OR. LSBP .GT. 0 ) .AND. NPAS .GT. 1 ) THEN IF ( NCAT(10,LZ) .GT. 0 ) THEN LN = NCAT(10,LZ) - L0 DO 60 II = 1 , NIPAR NCT(II) = NCAT(II,LN) 60 CONTINUE DO 70 II = 1 , NRPAR PMT(II) = PMTR(II,LN) 70 CONTINUE DO 80 II = 0 , MAXSUB PRC(II) = PRCT(II,LN) 80 CONTINUE ENDIF CALL TWODIM( AS , MAS , JAPYS , IBUFS , LZ , & APSF , FPSF , IPSF , NCAT , PMTR , & PRCT , NCT , PMT , PRC , IARR , & RARR , SIG ) C C *** Subtract the object. C IOPC = -1 CALL STARSA( IOPC , AS , JAPYS , IBUFS , I , & J , LPXL , LSBP , NCAT(1,LZ) , PMTR(1,LZ) , & PRCT(0,LZ) , APSF , FPSF , 3 , SCALE , & CINT2 ) C C *** Subtract the brightest stellar component if necessary. C IF ( NCAT(10,LZ) .GT. 0 ) THEN CALL STARSA( IOPC , AS , JAPYS , IBUFS , I , & J , LPXL , LSBP , NCT , PMT , & PRC , APSF , FPSF , 3 , SCALE , & CINT2 ) ENDIF IF ( LDBG .GE. 3 ) THEN CALL PROFIL( AS , MAS , JAPYS , IBUFS , 0 , & 0 , LHED , LDBG , BGRD , HCUT , & PRFL , ICNT ) ENDIF C C *** Search for additional faint objects. C CALL SRHNEW( AS , MAS , JAPYS , IBUFS , LHED , & I , J , TRSH , FLTR , BGRD , & SIG , MCM ) ENDIF C C *** Record newly found objects. C IF ( ID .LE. M .AND. ( .NOT. ( IVRF .EQ. 0 .AND. & IARR(2) .EQ. 0 ) ) ) THEN IF ( NPAS .GT. 1 .AND. NPAS .LE. IARR(2) ) THEN CALL NEWOBJ( AS , JAPYS , IBUFS , 0 , 0 , & NREG , LSTP , NCAT , PMTR , PRCT , & ID , L0 , L1 , LW , MM , & TRSH , ADLM , MCM ) ELSE IF ( NPAS .EQ. 1 ) THEN CALL NEWOBJ( A , JAPY , IBUF , I , J , & NREG , LSTP , NCAT , PMTR , PRCT , & ID , L0 , L1 , LW , MM , & TRSH , ADLM , MCM ) ENDIF ENDIF C RETURN C END