C @(#)rfotregist.for	19.1 (ES0-DMD) 02/25/03 13:30: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 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
