C @(#)inttab.for	19.1 (ES0-DMD) 02/25/03 13:29: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
      SUBROUTINE INTINI(INTNAM,TIDINT)
C++
C.Purpose: Create the intermediate table with the following columns
C.         col 1       : group identification                 format = I
C.         col 2:      : component identification (star or hole)       I
C.         col 3 to 18 : general window paremeters                     R
C.         col 19      : flag parameter                                C*2
C.         col 20 to 25: fit parameters                                R
C.Author:  Rein Warmels, ESO Garching
C.Version: 890812  RHW  Type column taken out
C--
      IMPLICIT        NONE
      CHARACTER*60    INTNAM
      INTEGER         TIDINT
C
      INTEGER         NGRP
      INTEGER         NIDN
      INTEGER         NGEN
      INTEGER         NFLG
      INTEGER         NPAR
      INTEGER         NRINT
      PARAMETER       (NGRP=1)
      PARAMETER       (NIDN=1)
      PARAMETER       (NGEN=16)
      PARAMETER       (NFLG=1)
      PARAMETER       (NPAR=6)
      PARAMETER       (NRINT=10000)
      INTEGER         NROW
      INTEGER         NCINT
      INTEGER         ISTAT
      INTEGER         I

      CHARACTER*80    STRING
      CHARACTER*16    FORMI2
      CHARACTER*16    FORMI6
      CHARACTER*16    FORMR4
      CHARACTER*16    UNIT
C
      CHARACTER*16    LABGRP
      CHARACTER*16    LABIDN
      CHARACTER*16    LABGEN(16)
      CHARACTER*16    LABFLG
      CHARACTER*16    LABPAR(6)
C
      INTEGER         INTTYP
      INTEGER         INTCOL
      CHARACTER*16    INTFOR
      CHARACTER*16    INTUNI
      CHARACTER*16    INTLAB

      INCLUDE         'MID_INCLUDE:ST_DEF.INC'
      INCLUDE         'MID_INCLUDE:ST_DAT.INC'
C
      DATA            NROW/1000/
      DATA            FORMI2/'I2'/
      DATA            FORMI6/'I6'/
      DATA            FORMR4/'E12.4'/
      DATA            UNIT/'    '/
      DATA            LABGRP/'GROUP '/
      DATA            LABIDN/'IDENT'/
      DATA            LABGEN/'WND_XSTA', 'WND_YSTA', 'MAG1    ', 
     2                       'MAG2    ', 'MAG3    ', 'WND_XDIM', 
     3                       'WND_YDIM', 'BG_XCOEF', 'BG_YCOEF', 
     4                       'BG      ', 'BETA    ', 'VARIANCE',
     4                       'FIT_ITER', 'WND_FL  ', 'N_CMP   ', 
     5                       'N_HOL   '/
      DATA            LABFLG/'CMP_FL  '/
      DATA            LABPAR/'INT_FIT ', 'X_FIT    ', 'Y_FIT  ',
     2                       'SIGMA   ', 'CHI_SQ   ', 'SIQ    '/

C
C *** create a new intermediate table
      NCINT = NGRP + NIDN + NGEN + NFLG + NPAR 
      CALL TBTINI(INTNAM,0,F_O_MODE,NCINT,NRINT,TIDINT,ISTAT)
      IF (ISTAT.NE.0) THEN
         STRING = '*** INFO: Problems with opening a new intermediate'//
     2            ' table'
         CALL STTPUT(STRING,ISTAT)
         CALL STSEPI
      ELSE
C 
C *** intialize the column for the group number
         INTTYP = D_I4_FORMAT
         INTFOR = FORMI6
         INTUNI = UNIT
         INTLAB = LABGRP
         CALL TBCINI(TIDINT,INTTYP,NGRP,INTFOR,INTUNI,
     2                      INTLAB,INTCOL,ISTAT)
C 
C *** intialize the column for the name of the component
         INTTYP = D_I4_FORMAT
         INTFOR = FORMI6
         INTUNI = UNIT
         INTLAB = LABIDN
         CALL TBCINI(TIDINT,INTTYP,NIDN,INTFOR,INTUNI,
     2                      INTLAB,INTCOL,ISTAT)
C 
C *** initialize the column for the standard data        
         DO 10 I = 1,NGEN
            INTTYP = D_R4_FORMAT
            INTFOR = FORMR4
            INTUNI = UNIT
            INTLAB = LABGEN(I)
            CALL TBCINI(TIDINT,INTTYP,1,INTFOR,INTUNI,
     2                         INTLAB,INTCOL,ISTAT)
  10     CONTINUE
C
C *** initialize the column for the component flag
         INTTYP = D_I4_FORMAT
         INTFOR = FORMI2
         INTUNI = UNIT
         INTLAB = LABFLG
         CALL TBCINI(TIDINT,INTTYP,NFLG,INTFOR,INTUNI,
     2                      INTLAB,INTCOL,ISTAT)
C
C *** initialize the column for the object parameters
         DO 20 I = 1,NPAR
            INTTYP = D_R4_FORMAT
            INTFOR = FORMR4
            INTUNI = UNIT
            INTLAB = LABPAR(I)
            CALL TBCINI(TIDINT,INTTYP,1,INTFOR,INTUNI,
     2                         INTLAB,INTCOL,ISTAT)
  20     CONTINUE
      ENDIF
C
      RETURN
      END


      SUBROUTINE INTDRD(IDEN,INTG1,INTG2,INTG3,
     2                  REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7)
C+++
C.PURPOSE: Write the table info into the descriptor
C---
      IMPLICIT NONE	
      INTEGER  IDEN
      INTEGER  INTG1,INTG2,INTG3
      REAL     REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7
C
      INTEGER  ISTAT, IACT, KUN, KNUL
C
      INTEGER IOUT(3)
      REAL    ROUT(7)
C
      INCLUDE      'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE      'MID_INCLUDE:ST_DAT.INC/NOLIST'
C     
      CALL STDRDR(IDEN,'INTPAR_R',1,7,IACT,ROUT,KUN,KNUL,ISTAT)
      REAL1  = ROUT(1)                                    !
      REAL2  = ROUT(2)                                    !
      REAL3  = ROUT(3)                                    !
      REAL4  = ROUT(4)                                    !
      REAL5  = ROUT(5)                                    !
      REAL6  = ROUT(6)                                    !
      REAL7  = ROUT(7)                                    !
C
      CALL STDRDI(IDEN,'INTPAR_I',1,3,IACT,IOUT,KUN,KNUL,ISTAT)
      INTG1  = IOUT(1)                                    ! number of groups
      INTG2  = IOUT(2)                                    ! number of components
      INTG3  = IOUT(3)                                    ! number of iterations
C
      RETURN
      END


      SUBROUTINE INTDWR(IDEN,INTG1,INTG2,INTG3,
     2                  REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7)
C+++
C---
      IMPLICIT NONE
      INTEGER  IDEN
      INTEGER  INTG1,INTG2,INTG3
      REAL     REAL1,REAL2,REAL3,REAL4,REAL5,REAL6,REAL7
C
      INTEGER  KUN, ISTAT
C
      INTEGER  IOUT(3)
      REAL     ROUT(7)
C
      INCLUDE      'MID_INCLUDE:ST_DEF.INC/NOLIST'
      INCLUDE      'MID_INCLUDE:ST_DAT.INC/NOLIST'
C     
      ROUT(1)  = REAL1                                    !
      ROUT(2)  = REAL2                                    !
      ROUT(3)  = REAL3                                    !
      ROUT(4)  = REAL4                                    !
      ROUT(5)  = REAL5                                    !
      ROUT(6)  = REAL6                                    !
      ROUT(7)  = REAL7                                    !
      CALL STDWRR(IDEN,'INTPAR_R',ROUT,1,7,KUN,ISTAT)
C
      IOUT(1)  = INTG1                                    ! number of groups
      IOUT(2)  = INTG2                                    ! number of components
      IOUT(3)  = INTG3                                    ! number of iterations
      CALL STDWRI(IDEN,'INTPAR_I',IOUT,1,3,KUN,ISTAT)
C    
      RETURN
      END


      SUBROUTINE INTWRD(TID,IROW,NCOMPS,NHOLES)
C+++
C.Purpose: Reads the intermediate table starting from row = IROW.
C.         The data will be stores in a THREE common blocks to be read by
C.         calling program.
C---
      IMPLICIT      NONE
      INTEGER       TID                         ! table identification
      INTEGER       IROW                        ! row indication where to start
      INTEGER       NCOMPS                      ! number of components in window
      INTEGER       NHOLES                      ! number of holes in window
C
      INCLUDE       'MID_REL_INCL:RFOTDECL.INC/NOLIST'
C
      INTEGER       ISTAT
      INTEGER       IR, IS, IH
      INTEGER       ICGRP
      INTEGER       ICIDN
      INTEGER       ICGEN(NINTP)
      INTEGER       ICFLG
      INTEGER       ICPAR(NINTC)
      INTEGER       TINULL
C
      DOUBLE PRECISION TDNULL,TDTRUE,TDFALS
C
      REAL          RNST, RNHL
      REAL          ROUT(NINTC)
      REAL          TRNULL,TBLSEL
C
      LOGICAL       NULL(NINTP)
C
C
      DATA          ICGRP/1/
      DATA          ICIDN/2/
      DATA          ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/
      DATA          ICFLG/19/
      DATA          ICPAR/20,21,22,23,24,25/
C
C *** start the code; first define the columns
      CALL TBMNUL(TINULL,TRNULL,TDNULL)
      CALL TBMCON(TBLSEL,TDTRUE,TDFALS)
C
C *** read general parameters
      CALL TBERDI(TID,IROW,ICGRP,IDNGRP,NULL,ISTAT)            ! group number
      CALL TBRRDR(TID,IROW,NINTP,ICGEN,PARINT,NULL,ISTAT)      ! gen. parameters
C
C *** read the star parameters
      CALL TBERDR(TID,IROW,ICGEN(15),RNST,NULL,ISTAT)          ! # stars
      CALL TBERDR(TID,IROW,ICGEN(16),RNHL,NULL,ISTAT)          ! # holes
      NCOMPS = INT(RNST)
      NHOLES = INT(RNHL)
C
C *** get the identification and fit parameters for the stars
      IF (NCOMPS.GT.0) THEN
         DO 100 IS = 1, NCOMPS
            IR = IROW + IS - 1
            CALL TBERDI(TID,IR,ICIDN,IDNCMP(IS),NULL,ISTAT)    ! ident comp.
            CALL TBERDI(TID,IR,ICFLG,FLGCMP(IS),NULL,ISTAT)    ! flag
            CALL TBRRDR(TID,IR,NINTC,ICPAR,ROUT,NULL,ISTAT)    ! comp. par.
            FITCMP((IS-1)*6+1) = ROUT(1)
            FITCMP((IS-1)*6+2) = ROUT(2)
            FITCMP((IS-1)*6+3) = ROUT(3)
            FITCMP((IS-1)*6+4) = ROUT(4)
            FITCMP((IS-1)*6+5) = ROUT(5)
            FITCMP((IS-1)*6+6) = ROUT(6)
 100     CONTINUE
      ENDIF
C
C*** get the hole parameters
      IF (NHOLES.GT.0) THEN
         DO 200 IH = 1, NHOLES
            IR = IROW + NCOMPS + IH - 1
            CALL TBERDI(TID,IR,ICIDN,IDNHOL(IH),NULL,ISTAT)    ! ident
            CALL TBERDI(TID,IR,ICFLG,FLGHOL(IH),NULL,ISTAT)    ! flag
            CALL TBRRDR(TID,IR,NINTH,ICPAR,ROUT,NULL,ISTAT)    ! hole par.
            FITHOL((IH-1)*3+1) = ROUT(1)
            FITHOL((IH-1)*3+2) = ROUT(2)
            FITHOL((IH-1)*3+3) = ROUT(3)
  200    CONTINUE
      ENDIF
C
      RETURN
      END


      SUBROUTINE INTWWR(TID,IROW,NCOMP,NHOLES)
C+++
C.Purpose: Writes the intermediate table starting from row = IROW.
C.         The data will be stores in a THREE common blocks to be read by
C.         calling program.
C---
      IMPLICIT      NONE
      INTEGER       TID                         ! table identification 
      INTEGER       IROW                        ! row indication where to start
      INTEGER       NCOMP                       ! number of components
      INTEGER       NHOLES                      ! number of holes
C
      INCLUDE       'MID_REL_INCL:RFOTDECL.INC/NOLIST'     ! array dimensions
C
      INTEGER       IR, IS, IH
      INTEGER       ISTAT
      INTEGER       ICGRP
      INTEGER       ICIDN
      INTEGER       ICGEN(NINTP)
      INTEGER       ICFLG
      INTEGER       ICPAR(NINTC)
      REAL          ROUT(NINTC)
C
      DATA          ICGRP/1/
      DATA          ICIDN/2/
      DATA          ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/
      DATA          ICFLG/19/
      DATA          ICPAR/20,21,22,23,24,25/
C
C *** write the star parameters
      DO 100 IS = 1,NCOMP
         IR   = IROW + IS - 1
         CALL TBEWRI(TID,IR,ICGRP,IDNGRP,ISTAT)          ! write group number
         CALL TBEWRI(TID,IR,ICIDN,IDNCMP(IS),ISTAT)      ! write sort object
         CALL TBRWRR(TID,IR,NINTP,ICGEN,PARINT,ISTAT)    ! write gen. pars.
         CALL TBEWRI(TID,IR,ICFLG,FLGCMP(IS),ISTAT)      ! write the flag
C 
         ROUT(1) = FITCMP((IS-1)*6+1)
         ROUT(2) = FITCMP((IS-1)*6+2)
         ROUT(3) = FITCMP((IS-1)*6+3)
         ROUT(4) = FITCMP((IS-1)*6+4)
         ROUT(5) = FITCMP((IS-1)*6+5)
         ROUT(6) = FITCMP((IS-1)*6+6)
         CALL TBRWRR(TID,IR,NINTC,ICPAR,ROUT,ISTAT)      ! write object par.
  100 CONTINUE
C
C*** write the hole parameters
      IF (NHOLES.GT.0) THEN
         DO 200 IH = 1, NHOLES
            IR = IROW + NCOMP + IH - 1
            CALL TBEWRI(TID,IR,ICGRP,IDNGRP,ISTAT)       ! write group number
            CALL TBEWRI(TID,IR,ICIDN,IDNHOL(IH),ISTAT)   ! write the sort object
            CALL TBRWRR(TID,IR,NINTP,ICGEN,PARINT,ISTAT) ! write gen. pars.
            CALL TBEWRI(TID,IR,ICFLG,FLGHOL(IH),ISTAT)   ! write the flag
C
            ROUT(1) = FITHOL((IH-1)*3+1)
            ROUT(2) = FITHOL((IH-1)*3+2)
            ROUT(3) = FITHOL((IH-1)*3+3)
            CALL TBRWRR(TID,IR,NINTH,ICPAR,ROUT,ISTAT)
  200    CONTINUE
      ENDIF
C
      RETURN
      END


      SUBROUTINE INTCWR(TID,IROW,INDEX)
C+++
C.Purpose: Writes a ro in the intermediate table at row = IROW.
C.         The data will be stores in a THREE common blocks to be read by
C.         calling program.
C---
      IMPLICIT      NONE
      INTEGER       TID                      ! table identification 
      INTEGER       IROW                     ! row indication where to start
      INTEGER       INDEX                    ! start index of component in table
C
      INCLUDE       'MID_REL_INCL:RFOTDECL.INC/NOLIST'          ! declarations
C
      INTEGER       ISTAT
      INTEGER       ICGRP
      INTEGER       ICIDN
      INTEGER       ICGEN(NINTP)
      INTEGER       ICFLG
      INTEGER       ICPAR(NINTC)
      REAL          ROUT(NINTC)
C
      DATA          ICGRP/1/
      DATA          ICIDN/2/
      DATA          ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/
      DATA          ICFLG/19/
      DATA          ICPAR/20,21,22,23,24,25/
C
C *** write the component parameters
      CALL TBEWRI(TID,IROW,ICGRP,IDNGRP,ISTAT)           ! write group number
      CALL TBEWRI(TID,IROW,ICIDN,IDNCMP(INDEX),ISTAT)    ! write the sort object
      CALL TBRWRR(TID,IROW,NINTP,ICGEN,PARINT,ISTAT)     ! write gen. parameters
      CALL TBEWRI(TID,IROW,ICFLG,FLGCMP(INDEX),ISTAT)    ! write the flag
C 
      ROUT(1) = FITCMP((INDEX-1)*6+1)                    ! copy comp. parameters
      ROUT(2) = FITCMP((INDEX-1)*6+2)
      ROUT(3) = FITCMP((INDEX-1)*6+3)
      ROUT(4) = FITCMP((INDEX-1)*6+4)
      ROUT(5) = FITCMP((INDEX-1)*6+5)
      ROUT(6) = FITCMP((INDEX-1)*6+6)
      CALL TBRWRR(TID,IROW,NINTC,ICPAR,ROUT,ISTAT)       ! write component par.
C
      RETURN
      END


      SUBROUTINE INTHWR(TID,IROW,INDEX)
C+++
C.Purpose: Writes a ro in the intermediate table at row = IROW.
C.         The data will be stores in a THREE common blocks to be read by
C.         calling program.
C---
      IMPLICIT      NONE
      INTEGER       TID                      ! table identification 
      INTEGER       IROW                     ! row indication where to start
      INTEGER       INDEX                    ! start index of component in table
C
      INCLUDE       'MID_REL_INCL:RFOTDECL.INC/NOLIST'
C
      INTEGER       ISTAT
      INTEGER       ICGRP
      INTEGER       ICIDN
      INTEGER       ICGEN(NINTP)
      INTEGER       ICFLG
      INTEGER       ICPAR(NINTH)
      REAL          ROUT(NINTH)
C
      DATA          ICGRP/1/
      DATA          ICIDN/2/
      DATA          ICGEN/3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18/
      DATA          ICFLG/19/
      DATA          ICPAR/20,21,22/
C
C *** write the component parameters
      CALL TBEWRI(TID,IROW,ICGRP,IDNGRP,ISTAT)           ! write group number
      CALL TBEWRI(TID,IROW,ICIDN,IDNHOL(INDEX),ISTAT)    ! write the sort object
      CALL TBRWRR(TID,IROW,NINTP,ICGEN,PARINT,ISTAT)     ! write gen. parameters
      CALL TBEWRI(TID,IROW,ICFLG,FLGHOL(INDEX),ISTAT)    ! write the flag
C 
      ROUT(1) = FITHOL((INDEX-1)*3+1)                    ! copy comp. parameters
      ROUT(2) = FITHOL((INDEX-1)*3+2)
      ROUT(3) = FITHOL((INDEX-1)*3+3)
      CALL TBRWRR(TID,IROW,NINTH,ICPAR,ROUT,ISTAT)       ! write component par.
C
      RETURN
      END
