C @(#)rfotregist.for 17.1.1.1 (ES0-DMD) 01/25/02 17:18:17 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 REGIST C+++ C.IDENTIFICATION: RFOTREGIST C.PURPOSE: Compute the absolute quantities and store the results in the final C MIDAS table C.AUTHOR: R. Buonanno, G. Buscema, C. Corsi, I. Ferraro, G. Iannicola C Osservatorio Astronomico di Roma C.VERSION: 16.09.87 First running version at ESO (outside MIDAS) R. Buonanno C 17.12.87 Installation in MIDAS R.H. Warmels C 24.10.88 New version R. Buonanno C 14.06.89 Rewritten for the portable MIDAS version C Inclusion of MIDAS tables R.H. Warmels C---- IMPLICIT NONE INCLUDE 'MID_REL_INCL:RFOTDECL.INC' C INTEGER NMAX INTEGER NCPAR INTEGER NRREG PARAMETER (NMAX=256) PARAMETER (NCPAR=12) PARAMETER (NRREG=10000) C *** INTEGER ED, EC, EL INTEGER ICPAR(NCPAR) INTEGER IDENT(NRREG) INTEGER IROW, ICIDN, IREGI, IGRP INTEGER ISTAT, IAC, IAV INTEGER I, IS, IH, IC, IK, IVN INTEGER KUN, KNUL, KONT INTEGER IPX, IPY INTEGER JC INTEGER K7, K8 INTEGER LF9 INTEGER MADRID(1) INTEGER NRINT,NCINT INTEGER NACINT,NARINT,NSINT INTEGER NOBJ, NGRP, NSR INTEGER NCP, NHL, NCOM INTEGER NCREG INTEGER REGTYP, REGCOL INTEGER TIDINT INTEGER TIDREG C *** REAL ABC REAL ALTMIN REAL B, BETA REAL BU(NMAX) REAL DATR(NCPAR,NRREG) REAL D1, D2, D3, D4, D6, D7 REAL FOG, FAT, FONDF, FOND REAL GRE REAL P(NMAX) REAL SIGMA, SOFOT, SAT REAL PP1, PP2 REAL SQM(NMAX), SIQ(NMAX) REAL U REAL V REAL VOL C *** CHARACTER*60 INTFIL CHARACTER*60 REGFIL CHARACTER*80 STRING CHARACTER*16 LABEL(NCPAR),REGLAB CHARACTER*16 UNIT(NCPAR),REGUNI CHARACTER*16 REGFOR CHARACTER*16 FORMR4,FORMI4 CHARACTER*1 SST, CAR C *** INCLUDE 'MID_INCLUDE:TABLES.INC' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:TABLED.INC' C *** DATA ICIDN/1/ DATA FORMI4/'I6'/ DATA FORMR4/'E12.4'/ DATA LABEL /'X ', 'Y ', 'INT ', 'BG ', 2 'MAG1 ', 'MAG2 ', 'MAG3 ', 'MAG_CNV ', 3 'SIGMA ', 'BETA ', 'SIQ ', 'CHI_SQ '/ DATA UNIT /'PIXEL ', 'PIXEL ', ' ', ' ', 2 'MAG. ', 'MAG. ', 'MAG. ', 'MAG. ', 3 ' ', ' ', ' ', ' '/ C *** 9001 FORMAT('*** INFO: Window ',I5,' not fitted') 9002 FORMAT('*** INFO: Window ',I5,' not registered (no conv. ', * 'or already regist.)') C---------------------------------------------------------------------------- CALL STSPRO('REGISTER') C C *** get the input CALL STKRDC('IN_A',1,1,60,IAC,INTFIL,KUN,KNUL,ISTAT) CALL STKRDC('OUT_A',1,1,60,IAC,REGFIL,KUN,KNUL,ISTAT) C C *** CALL STECNT('GET',EC,ED,EL) CALL STECNT('PUT',1,0,0) CALL TBTOPN(INTFIL,F_I_MODE,TIDINT,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Error opening intermediate table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF C CALL TBIGET(TIDINT,NCINT,NRINT,NSINT,NACINT,NARINT,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Problems with getting table info '// 2 'of intermediate table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF IF (NRINT.EQ.0) THEN STRING = '*** FATAL: There are no data in the intermediate '// 2 'table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF C C *** create the registration table NCREG = NCPAR + 1 CALL TBTINI(REGFIL,0,F_O_MODE,NCREG,NRREG,TIDREG,ISTAT) IF (ISTAT.NE.0) THEN STRING = '*** FATAL: Problems with opening a new '// 2 'registration table' CALL STTPUT(STRING,ISTAT) CALL STSEPI ENDIF CALL STECNT('PUT',EC,ED,EL) C REGTYP = D_I4_FORMAT REGFOR = FORMI4 REGUNI = ' ' REGLAB = 'IDENT' CALL TBCINI(TIDREG,REGTYP,1,REGFOR,REGUNI, 2 REGLAB,REGCOL,ISTAT) ! create the ident column C DO 101 I = 1,NCPAR ICPAR(I) = I + 1 REGTYP = D_R4_FORMAT REGFOR = FORMR4 REGUNI = UNIT(I) REGLAB = LABEL(I) CALL TBCINI(TIDREG,REGTYP,1,REGFOR,REGUNI, 2 REGLAB,REGCOL,ISTAT) ! create the data columns 101 CONTINUE C C *** read the window and object option CALL STKRDC('INPUTC',1,1,1,IAV,CAR,KUN,KNUL,ISTAT) CALL STKRDC('INPUTC',1,2,1,IAV,SST,KUN,KNUL,ISTAT) C C *** read the table descriptor CALL INTDRD(TIDINT,NGRP,NOBJ,NSR,SAT,FAT,SIGMA,BETA,SOFOT, 2 ALTMIN,FOG) C C *** do the work KONT = 0 IROW = 1 IGRP = 1 C 1001 CONTINUE CALL INTWRD(TIDINT,IROW,NCP,NHL) D1 = PARINT(1) D2 = PARINT(2) V = PARINT(3) B = PARINT(4) U = PARINT(5) D3 = PARINT(6) D4 = PARINT(7) P(1) = PARINT(8) P(2) = PARINT(9) P(3) = PARINT(10) BETA = PARINT(11) D7 = PARINT(12) D6 = PARINT(13) GRE = PARINT(14) C DO 1011 IS = 1,NCP P((IS-1)*4+4) = FITCMP((IS-1)*6+1) P((IS-1)*4+5) = FITCMP((IS-1)*6+2) P((IS-1)*4+6) = FITCMP((IS-1)*6+3) P((IS-1)*4+7) = FITCMP((IS-1)*6+4) SQM(IS) = FITCMP((IS-1)*6+5) SIQ(IS) = FITCMP((IS-1)*6+6) 1011 CONTINUE C DO 1012 IH = 1,NHL BU((IH-1)*3+1) = FITHOL((IH-1)*3+1) BU((IH-1)*3+2) = FITHOL((IH-1)*3+2) BU((IH-1)*3+3) = FITHOL((IH-1)*3+3) 1012 CONTINUE C C *********************************************************** IREGI = 0 IF (CAR.EQ.'A') THEN IREGI = 1 ENDIF IF (CAR.EQ.'F' .AND. GRE.NE.2) THEN IREGI = 1 ENDIF C IF (IREGI.EQ.1) THEN IPX = INT(D1) IPY = INT(D2) NCOM = 0 LF9 = 0 C DO 1013 IC = 1,NCP K7 = (IC-1)*4 + 4 IVN = FLGCMP(IC) IF (IVN.EQ.1 .OR. CAR.EQ.'A' .OR. IVN.EQ.2) THEN C*** C CAR=F CAR=A C | | C ______|______ ______|______ C | | | | C | | | | C F.R.:NO F.R.:NO F.R.:VOL=0 F.R.:VOL=0 C TESTEF:VOL TESTEF:VOL=0 TESTEF:VOL TESTEF:VOL=0 C *** IF (IVN.EQ.1 .OR. (IVN.EQ.2 .AND. SST.EQ.'Y')) THEN LF9 = 1 KONT = KONT+1 FOND = P(1)*P(K7+1)+P(2)*P(K7+2)+P(3) FONDF = 0. C DO 1014 JC = 1,NCP K8 = (JC-1)*4+4 IF (K8.NE.K7) THEN IF (FLGCMP(JC).EQ.1) THEN ABC = ((P(K7+1)-P(K8+1))**2 + 2 (P(K7+2)-P(K8+2))**2)/P(K8+3)**2 IF (BETA.EQ.0.) THEN ABC = P(K8)*EXP(-ABC*4*ALOG(2.)) ELSE ABC = P(K8)*(1+ABC)**(-BETA) END IF FONDF = FONDF + ABC END IF END IF 1014 CONTINUE FOND = FOND+FONDF C IF (BETA.EQ.0.) THEN IF (P(K7).LE.0.) THEN VOL = 0. ELSE VOL = -2.5*ALOG10(P(K7+3)**2* 2 P(K7)*3.1416/(4*ALOG(2.))) END IF ELSE IF (P(K7).LE.0.) THEN VOL = 0. ELSE VOL = -2.5*ALOG10(3.14159* 2 P(K7+3)**2*P(K7)/(BETA-1)) END IF END IF C ELSE KONT = KONT+1 VOL = 0 END IF C PP1 = P(K7+1)+IPX-1 PP2 = P(K7+2)+IPY-1 C IDENT(KONT) = IDNGRP*100+(IDNCMP(IC)-100) DATR(1,KONT) = PP1 DATR(2,KONT) = PP2 DATR(3,KONT) = P(K7) DATR(4,KONT) = FOND DATR(5,KONT) = V DATR(6,KONT) = B DATR(7,KONT) = U DATR(8,KONT) = VOL DATR(9,KONT) = P(K7+3) DATR(10,KONT) = BETA DATR(11,KONT) = SIQ(IC) DATR(12,KONT) = SQM(IC) END IF 1013 CONTINUE C ELSE IF (GRE.EQ.0) THEN WRITE (STRING,9001) IC ELSE WRITE(STRING,9002) IC END IF CALL STTPUT(STRING,ISTAT) END IF IROW = IROW + NCP + NHL IF (IROW.LE.NRINT) then GO TO 1001 ENDIF C C *** fill the table DO 102 IK = 1,KONT CALL TBRWRI(TIDREG,IK,1,ICIDN,IDENT(IK),ISTAT) CALL TBRWRR(TIDREG,IK,NCPAR,ICPAR,DATR(1,IK),ISTAT) 102 CONTINUE CALL TBSINI(TIDREG,ISTAT) CALL TBTCLO(TIDREG,ISTAT) CALL STSEPI END