C @(#)tmask.for 17.1.1.1 (ES0-DMD) 01/25/02 17:17:58 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 SUBROUTINE TMASK(KAMP,DAK,CMA,PAR,NCO,BET,NPU,IVX,IVY, * ITER,MX,MY,MR,MC,PMA,KFL) C IMPLICIT NONE INTEGER KAMP(10000,15,2) REAL DAK(2000,3) REAL CMA REAL PAR(1) INTEGER NCO REAL BET INTEGER NPU INTEGER IVX(1) INTEGER IVY(1) INTEGER ITER INTEGER MX(1) INTEGER MY(1) INTEGER MR INTEGER MC REAL PMA INTEGER KFL C INTEGER NPAR INTEGER MC2, MR2 INTEGER KR INTEGER I, II, IR, J INTEGER IXF, IYF INTEGER IDX, IDY, INDI INTEGER INX, INY INTEGER KDX, KDY INTEGER KRX(100),KRY(100),KRM(100) INTEGER LX, LY INTEGER ISCA, IA, LF, LF1 INTEGER IND INTEGER ISTAT REAL RMAG REAL D1, D2, DH REAL PARS(300) REAL RX, RY C NPAR=NCO*4+3 MC2=MC/2+1 MR2=MR/2+1 KR=0 C IF (ITER.EQ.1) THEN DO 10 I=1,NPAR PARS(I)=PAR(I) 10 CONTINUE DO 20 I=1,NPU MX(I)=0 MY(I)=0 20 CONTINUE KR=1 ELSE DO 30 I=1,NCO IND=4*I D1=ABS(PARS(IND+1)-PAR(IND+1)) D2=ABS(PARS(IND+2)-PAR(IND+2)) DH=-2.5*ALOG10(PARS(IND)/PAR(IND)) IF(D1.GE.0.1) KRX(I)=1 IF(D2.GE.0.1) KRY(I)=1 IF(DH.GE.PMA) KRM(I)=1 IF(KRX(I).EQ.1.OR.KRY(I).EQ.1.OR.KRM(I).EQ.1) KR=1 30 CONTINUE END IF C IF (KR.EQ.1) THEN KFL=0 DO 40 II=1,NCO IND=II*4 RX=PAR(IND+1)-INT(PAR(IND+1)) RY=PAR(IND+2)-INT(PAR(IND+2)) IXF=INT(RX*10+.5) IYF=INT(RY*10+.5) KDX=0 KDY=0 IF(IXF.EQ.5.AND.RX.GT..5) KDX=-1 IF(IYF.EQ.5.AND.RY.GT..5) KDY=-1 IF (IXF.LE.5) THEN IXF=IXF+5 ELSE IXF=IXF-5 END IF IF (IYF.LE.5) THEN IYF=IYF+5 ELSE IYF=IYF-5 END IF RMAG = -2.5*ALOG10(PAR(IND)*3.14159*PAR(IND+3)**2/ 2 (BET-1))+CMA IF (RMAG.LT.DAK(1,3)) THEN RMAG=DAK(1,3) KFL=1 END IF LX=0 LY=0 IF (IXF.GT.5) THEN IXF=10-IXF LX=1 END IF IF (IYF.GT.5) THEN IYF=10-IYF LY=1 END IF ISCA = 0 IF (IYF.LT.IXF) THEN IA=IXF IXF=IYF IYF=IA ISCA=1 END IF LF=0 LF1=0 I=0 C 12 CONTINUE IF (LF.NE.0) GO TO 11 I=I+1 IF (I.GE.2000) THEN IF (LF1.EQ.0) THEN CALL STTPUT('***FATAL: Too many data points'// 2 ' (TMASK)',ISTAT) CALL STSEPI ELSE I=IR LF=1 END IF ELSE IF (INT(DAK(I,1)*10+.5).EQ.IXF) THEN IF (INT(DAK(I,2)*10+.5).EQ.IYF) THEN IF (RMAG.GE.DAK(I,3)) THEN IF (DAK(I,3).GT.0.1) THEN LF1=1 IR=I IF (RMAG-PMA.LT.DAK(I,3)) THEN LF=1 END IF END IF END IF END IF END IF END IF GO TO 12 C 11 CONTINUE INDI=(IR-1)*MR DO 50 J=1,NPU IDX=INT(PAR(IND+1)+.5)-IVX(J) IDY=INT(PAR(IND+2)+.5)-IVY(J) IDX=IDX+KDX IDY=IDY+KDY IF (LX.EQ.1) IDX=-IDX IF(LY.EQ.1) IDY=-IDY IF (ISCA.EQ.1) THEN IA=IDX IDX=IDY IDY=IA END IF INX=MC2-IDX INY=MR2-IDY IF (INX.GE.1 .AND. INX.LE.MC .AND. 2 INY.GE.1.AND.INY.LE.MR) THEN MX(J)=MAX0(MX(J),KAMP(INDI+INY,INX,1)) MY(J)=MAX0(MY(J),KAMP(INDI+INY,INX,2)) ELSE MX(J)=MAX0(MX(J),1) MY(J)=MAX0(MY(J),1) END IF 50 CONTINUE 40 CONTINUE C DO 60 I=1,NCO IND=4*I IF (KRM(I).EQ.1) THEN PARS(IND)=PAR(IND) KRM(I)=0 END IF IF (KRX(I).EQ.1) THEN PARS(IND+1)=PAR(IND+1) KRX(I)=0 END IF IF (KRY(I).EQ.1) THEN PARS(IND+2)=PAR(IND+2) KRY(I)=0 END IF 60 CONTINUE END IF C RETURN END