C @(#)rfotadapt.for 17.1.1.1 (ES0-DMD) 01/25/02 17:18:15 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 PROGRAM ADAPT C+++ C.IDENT: RFOTADAPT C.PURPOSE: Use fit on template frame to derive trial values for fitting new C frame C.AUTHOR: R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola C Osservatorio Astronomico di Roma C.VERSION: 880930 RHW Installation in MIDAS C 890915 RHW MIDAS tables included; partially rewritten C.VERSION: 900121 RHW All variables declared; implicit none included C.VERSION: 900122 RHW IMPLICIT NONE added; all variables defined C---- IMPLICIT NONE INCLUDE 'MID_REL_INCL:RFOTDECL.INC' C INTEGER EC, ED, EL INTEGER IAV,IAC INTEGER ICP, IHL INTEGER IROW INTEGER ISTAT INTEGER JC, JH INTEGER KF INTEGER KSX,KSY INTEGER KUN,KNUL INTEGER KVI(2) INTEGER MADRID(1) INTEGER NCP, NHL INTEGER NCINT,NRINT,NSINT INTEGER NACINT,NARINT INTEGER TIDINT C REAL DX, DY REAL CDS REAL FMA REAL HF REAL TSH C CHARACTER INTFIL*60 CHARACTER RSN CHARACTER STRING*80 C INCLUDE 'MID_INCLUDE:ST_DEF.INC' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC' C C *** Is MIDAS out there CALL STSPRO('ADAPT') C C *** read the intermediate file CALL STKRDC('IN_A',1,1,60,IAC,INTFIL,KUN,KNUL,ISTAT) ! intermediate file CALL STECNT('GET',EC,ED,EL) CALL STECNT('PUT',1,0,0) CALL TBTOPN(INTFIL,F_IO_MODE,TIDINT,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Problems with opening intermediate'// 2 ' table ... ' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF C C *** get table info CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Problems with getting info for '// 2 ' intermediate table; Try again ... ' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF IF (NRINT.EQ.0) THEN STRING = '*** FATAL: No data points in intermediate table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF CALL STECNT('PUT',EC,ED,EL) C C *** get the multiplier intensity, background, and holes CALL STKRDR('INPUTR',1,1,IAV,TSH,KUN,KNUL,ISTAT) ! threshold CALL STKRDR('INPUTR',2,1,IAV,FMA,KUN,KNUL,ISTAT) ! intensity CALL STKRDR('INPUTR',3,1,IAV,CDS,KUN,KNUL,ISTAT) ! background CALL STKRDR('INPUTR',4,1,IAV,HF,KUN,KNUL,ISTAT) ! holes factor CALL STKRDI('INPUTI',1,2,IAV,KVI,KUN,KNUL,ISTAT) ! area KSX = KVI(1) KSY = KVI(2) C C *** do the work RSN = 'Y' IROW = 1 C C *** loop through all groups 101 CONTINUE CALL INTWRD(TIDINT,IROW,NCP,NHL) DX = 0 DY = 0 KF = 0 C IF (PARINT(1).LT.1) THEN KF = 2 IF (PARINT(1)+PARINT(6) .GT. 3) THEN PARINT(6) = PARINT(6) + PARINT(1) - 1 DX = PARINT(1)-1 PARINT(1) = 1 ELSE KF=1 END IF END IF C IF (KF.NE.1) THEN IF (PARINT(2).LT.1) THEN KF = 2 IF (PARINT(2)+PARINT(7) .GT. 3) THEN PARINT(7) = PARINT(7)+PARINT(2)-1 DY = PARINT(2)-1 PARINT(2) = 1 ELSE KF = 1 END IF ENDIF END IF C IF (KSX.NE.0) THEN IF (KF.NE.1) THEN IF (PARINT(1)+PARINT(6)-1 .GT. KSX) THEN KF = 2 IF (KSX-PARINT(1)+1 .GT. 3) THEN PARINT(6) = KSX-PARINT(1)+1 ELSE KF = 1 END IF ENDIF END IF END IF C IF (KSY.NE.0) THEN IF (KF.NE.1) THEN IF (PARINT(2)+PARINT(7)-1 .GT. KSY) THEN KF = 2 IF (KSY-PARINT(2)+1.GT.3) THEN PARINT(7) = KSY-PARINT(2)+1 ELSE KF = 1 END IF END IF ENDIF END IF C C*** chnage the background with a factor CDS PARINT(10) = PARINT(10)*CDS C DO 200 JC = 1,NCP ICP = (JC-1)*6 FITCMP(ICP+2) = FITCMP(ICP+2)+DX FITCMP(ICP+3) = FITCMP(ICP+3)+DY IF (FITCMP(ICP+1).LT.TSH) THEN FLGCMP(JC) = 0 ELSE IF (FLGCMP(JC).NE.1 .AND. RSN.EQ.'Y') THEN FLGCMP(JC) = 1 ENDIF END IF C FITCMP(ICP+1) = FITCMP(ICP+1)*FMA IF (KF.EQ.1) THEN FLGCMP(JC) = 0 ELSE IF (KF.EQ.2) THEN IF (FITCMP(ICP+2).LT.2) THEN FLGCMP(JC) = 0 ENDIF IF (FITCMP(ICP+3).LT.2) THEN FLGCMP(JC) = 0 ENDIF IF (FITCMP(ICP+2) .GE. PARINT(6)-1) THEN FLGCMP(JC) = 0 ENDIF IF (FITCMP(ICP+3).GE.PARINT(7)-1) THEN FLGCMP(JC) = 0 ENDIF END IF 200 CONTINUE C DO 400 JH = 1,NHL IHL = (JH-1)*3 FITHOL(IHL+1) = FITHOL(IHL+1)*HF FITHOL(IHL+2) = FITHOL(IHL+2)+DX FITHOL(IHL+3) = FITHOL(IHL+3)+DY 400 CONTINUE C C *** rewrite the window CALL INTWWR(TIDINT,IROW,NCP,NHL) IROW = IROW + NCP + NHL IF (IROW.LE.NRINT) THEN GO TO 101 ENDIF C CALL TBTCLO(TIDINT,ISTAT) CALL STSEPI END