C @(#)optab.for	17.1.1.1 (ES0-DMD) 01/25/02 17:55:13
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
C @(#)optab.for	17.1.1.1 (ESO-IPG) 17:55:13 01/25/02
         PROGRAM OPTAB
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.IDENTIFICATION: OPTAB.FOR
C.PURPOSE: Create and fill in TYPE and CHECK columns
C.AUTHOR: Alessandra Gemmo               Padova Department of Astronomy
C.VERSION:  910617 AG Creation
C.VERSION:  910826 AG Modified to include TBLSER routine and move computation
C.                    of precession to a separate procedure.
C-------------------------------------------------------------------------------
         IMPLICIT NONE
C
C ***
C
         INTEGER       MADRID(1)
         INTEGER       NRINP
         INTEGER       NCINP
         INTEGER       NROUT
         INTEGER       NCOUT
         INTEGER       NCPAR1
         PARAMETER     (NCOUT=15)
         PARAMETER     (NCPAR1=2)
         PARAMETER     (NROUT=300)
         INTEGER       ISTAT,IAC
         INTEGER       KUN,KNUL
         INTEGER       NACINP,NARINP,NSINP
         INTEGER       OUTTYP,OUTCOL,OUTCO(2),COLNUM(10)
         INTEGER       TIDINP
         INTEGER       I1,I2,I5
C
C ***
C
         DOUBLE PRECISION        AHR,AMIN,ASEC
         DOUBLE PRECISION        DDEG,DMIN,DSEC
         DOUBLE PRECISION        DRA,DDEC
C
C ***
C
         CHARACTER*80     STRING(10)
         CHARACTER*60     INPFIL
         CHARACTER*16     LABEL1(NCPAR1),LABEL2,OUTLAB
         CHARACTER*16     UNIT1(NCPAR1),UNIT2,OUTUNI
         CHARACTER*16     OUTFOR
         CHARACTER*16     FORMC1
         CHARACTER*16     FORMR8(2)
         CHARACTER*1      CHECK
         CHARACTER*1      SIGN
C
C ***
C
         LOGICAL          NULL
C
C ***
C
         INCLUDE       'MID_INCLUDE:ST_DEF.INC'
         COMMON        /VMR/MADRID
         INCLUDE       'MID_INCLUDE:ST_DAT.INC'
C
C ***
C
         DATA          LABEL1/'RA     ','DEC    '/
         DATA          UNIT1 /'HOURS   ','DEGREES '/
         DATA          LABEL2/'CHECK   '/
         DATA          UNIT2 /'        '/
C
C ***
C
         DATA          FORMC1 /'A1'/
         DATA          FORMR8 /'F12.9','F12.9'/
C
C ***
C
         DATA          CHECK    /' '/
C
C *** start the code
C
         CALL STSPRO('OPTAB')
C
C *** get input table
C
         CALL STKRDC('OUTPUTF',1,1,60,IAC,INPFIL,KUN,KNUL,ISTAT)
C
C *** open input table
C
         CALL TBTOPN(INPFIL,F_IO_MODE,TIDINP,ISTAT)
C
C *** get information about input table
C
         CALL TBIGET(TIDINP,NCINP,NRINP,NSINP,NACINP,NARINP,ISTAT)
         IF(NRINP.EQ.0)THEN       !no rows in table
           STRING(1) = '*** FATAL: There are no data in input table'
           CALL STETER(9,STRING(1))
         ENDIF
C
C *** initialize CHECK column
C
           OUTTYP = D_C_FORMAT
           OUTFOR = FORMC1
           OUTUNI = UNIT2
           OUTLAB = LABEL2
           CALL TBCINI(TIDINP,OUTTYP,1,OUTFOR,OUTUNI,
     2                        OUTLAB,OUTCOL,ISTAT)
C
C *** fill in CHECK column
C
         DO I5=1,NRINP
           CALL TBEWRC(TIDINP,I5,OUTCOL,CHECK,ISTAT)
         ENDDO
C
C *** initialize DRA and DDEC columns
C
         DO I1=1,NCPAR1
           OUTTYP = D_R8_FORMAT
           OUTFOR = FORMR8(I1)
           OUTUNI = UNIT1(I1)
           OUTLAB = LABEL1(I1)
           CALL TBCINI(TIDINP,OUTTYP,1,OUTFOR,OUTUNI,
     2                        OUTLAB,OUTCO(I1),ISTAT)
         ENDDO
C
C *** fill in DRA and DDEC columns
C
         DO I2=1,NRINP
           CALL TBLSER(TIDINP,'AHR',COLNUM(1),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(1),AHR,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'AMIN',COLNUM(2),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(2),AMIN,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'ASEC',COLNUM(3),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(3),ASEC,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'SIGN',COLNUM(4),ISTAT)
           CALL TBERDC(TIDINP,I2,COLNUM(4),SIGN,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'DDEG',COLNUM(5),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(5),DDEG,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'DMIN',COLNUM(6),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(6),DMIN,NULL,ISTAT)
C
           CALL TBLSER(TIDINP,'DSEC',COLNUM(7),ISTAT)
           CALL TBERDD(TIDINP,I2,COLNUM(7),DSEC,NULL,ISTAT)
C
           DRA = AHR+AMIN/60.+ASEC/3600.
           DDEC = DDEG+DMIN/60.+DSEC/3600.
           IF(SIGN.EQ.'-')DDEC = -DDEC
C
           CALL TBEWRD(TIDINP,I2,OUTCO(1),DRA,ISTAT)
           CALL TBEWRD(TIDINP,I2,OUTCO(2),DDEC,ISTAT)
         ENDDO  
C
C *** close the table
C
         CALL TBTCLO(TIDINP,ISTAT)
C *** over and out
C
         CALL STSEPI
         END