C @(#)tbldaomid.for 17.1.1.1 (ES0-DMD) 01/25/02 17:14:18 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++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.PROGRAM: TBLDAOMID ("TBL(:)DAO(to)MIDAS") C.AUTHOR: P. Figon, LAS Marseille 4eme trimestre 1985 C.Purpose: Convert DAOPHOT tables into MIDAS tables C ISSUES DE DAOPHOT EN TABLES MIDAS C.VERSION: F. Murtagh, ST-ECF, July 1987 (Allow for .ADD files). C F. Murtagh, ST-ECF, April 1987 (Comments in English). C F. Murtagh, ST-ECF, April 1987 (Allow for .ALS files). C F. Murtagh, ST-ECF, April 1987 (Keyw. TRANSF read for start/step). C F. Murtagh, ST-ECF, April 1987 (Col. labels: X to X_COORD, etc.) C.VERSION: 910510 RHW rewriten for portable version C.VERSION: 910815 RHW change column names to :X_COORD and :YCOORD (was :X, :Y) C------------------------------------------------------------------ PROGRAM DAOMID C IMPLICIT NONE INTEGER MADRID(1) DOUBLE PRECISION STASTE(4) CHARACTER*3 EXT CHARACTER*4 TYPE CHARACTER*60 NAME CHARACTER*60 TABLE CHARACTER*80 BID,BL REAL X,Y,MG,SH,R0,ST,CHI,MS,IT INTEGER I, J, IST, ICOL, NACT INTEGER TID INTEGER ITYP, RTYP INTEGER NROW, NROW2, NCOL INTEGER KUN, KNUL, NCARA, NELEM, BYTEL C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C C *** initialize the MIDAS environment CALL STSPRO('DAOMID') C C *** get the table name to convert CALL STKRDC('IN_A',1,1,60,NCARA,NAME,KUN,KNUL,IST) C C *** check the name of the table IF (NAME(1:1).EQ.'?') THEN CALL STTPUT('*** FATAL: No DAOPHOT table name given',IST) CALL STSEPI END IF DO I=1,NCARA IF (NAME(I:I).EQ.'.') GO TO 12 END DO CALL STTPUT('*** FATAL: Table name requires extension',IST) CALL STSEPI C 12 CONTINUE EXT=NAME(I+1:I+3) CALL UPCAS(EXT,EXT) IF (EXT.NE.'COO' .AND. EXT.NE.'PK '.AND. EXT.NE.'NST' .AND. 2 EXT.NE.'ADD'.AND.EXT.NE.'ALS') THEN CALL STTPUT('*** FATAL: Only .COO, .PK, .ALS, .ADD '// 2 'and .NST tables',IST) CALL STSEPI END IF TABLE = NAME(1:I-1)//EXT CALL LOWCAS(TABLE,TABLE) C C *** Get start and step values from keyword TRANSF CALL STKFND('TRANSF',TYPE,NELEM,BYTEL,IST) IF (NELEM.EQ.0) THEN CALL STTPUT(' *** INFO: Keyword TRANSF missing; world and '// 2 'pixel coords. assumed identical.',IST) STASTE(1) = 0.0 STASTE(2) = 0.0 STASTE(3) = 1.0 STASTE(4) = 1.0 ELSE CALL STTPUT('*** INFO: Get start/step values from '// 2 ' keyword TRANSF...',IST) CALL STKRDD('TRANSF',1,4,NACT,STASTE,KUN,KNUL,IST) ENDIF C C *** open the daophot table OPEN(UNIT=20,FILE=NAME,STATUS='OLD') C C *** open scratch file OPEN(UNIT=30,STATUS='SCRATCH') C C *** get the useful line and their number BL=' ' DO I=1,3 READ(20,'(A)') BID END DO NROW=0 10 CONTINUE READ(20,'(A)',END=20) BID IF (BID.NE.BL) THEN NROW=NROW+1 WRITE(30,'(A)') BID END IF GO TO 10 20 CONTINUE REWIND 30 C C *** number of columns IF (EXT.EQ.'COO') THEN NCOL=6 ELSE IF(EXT.EQ.'PK '.OR. EXT.EQ.'NST'.OR. EXT.EQ.'ALS') THEN NCOL=9 ELSE IF(EXT.EQ.'ADD') THEN NCOL=4 END IF C C *** create MIDAS tables NROW2 = NROW*2 CALL TBTINI(TABLE,0,F_O_MODE,NCOL,NROW2,TID,IST) C C *** define the columns ITYP = D_I4_FORMAT RTYP = D_R4_FORMAT IF (EXT.EQ.'COO') THEN CALL TBCINI(TID,ITYP,1,'I4', ' ','I', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','X_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','Y_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','SH', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','R0', ICOL,IST) ELSE IF(EXT.EQ.'ADD') THEN CALL TBCINI(TID,ITYP,1,'I4', ' ','I', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','X_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','Y_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST) ELSE IF(EXT.EQ.'PK '.OR.EXT.EQ.'NST'.OR.EXT.EQ.'ALS') THEN CALL TBCINI(TID,ITYP,1,'I4', ' ','I', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','X_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.2',' ','Y_COORD', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','MG', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','ST', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','MS', ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.0',' ','IT', ICOL,IST) CALL TBCINI(TID,RTYP,1, 'F5.2',' ','CHI',ICOL,IST) CALL TBCINI(TID,RTYP,1,'F10.3',' ','SH', ICOL,IST) END IF C C *** write the table IF (EXT.EQ.'COO') THEN DO J=1,NROW READ(30,*) I,X,Y,MG,SH,R0 X = X*STASTE(3) + STASTE(1) ! Transf. coords. from pix. Y = Y*STASTE(4) + STASTE(2) ! coords. to world coords. CALL TBEWRI(TID,J,1,I, IST) CALL TBEWRR(TID,J,2,X, IST) CALL TBEWRR(TID,J,3,Y, IST) CALL TBEWRR(TID,J,4,MG,IST) CALL TBEWRR(TID,J,5,SH,IST) CALL TBEWRR(TID,J,6,R0,IST) END DO ELSE IF(EXT.EQ.'ADD') THEN DO J=1,NROW READ(30,*) I,X,Y,MG X = X*STASTE(3) + STASTE(1) ! Transf. coords. from pix. Y = Y*STASTE(4) + STASTE(2) ! coords. to world coords. CALL TBEWRI(TID,J,1,I, IST) CALL TBEWRR(TID,J,2,X, IST) CALL TBEWRR(TID,J,3,Y, IST) CALL TBEWRR(TID,J,4,MG,IST) ENDDO ELSE IF(EXT.EQ.'PK '.OR.EXT.EQ.'NST'.OR.EXT.EQ.'ALS') THEN DO J=1,NROW READ(30,*) I,X,Y,MG,ST,MS,IT,CHI,SH X = X*STASTE(3) + STASTE(1) ! Transf. coords. from pix. Y = Y*STASTE(4) + STASTE(2) ! coords. to world coords. CALL TBEWRI(TID,J,1,I, IST) CALL TBEWRR(TID,J,2,X, IST) CALL TBEWRR(TID,J,3,Y, IST) CALL TBEWRR(TID,J,4,MG,IST) CALL TBEWRR(TID,J,5,ST,IST) CALL TBEWRR(TID,J,6,MS,IST) CALL TBEWRR(TID,J,7,IT,IST) CALL TBEWRR(TID,J,8,CHI,IST) CALL TBEWRR(TID,J,9,SH,IST) END DO END IF C C *** close the files CLOSE(20) CLOSE(30) CALL TBTCLO(TID,IST) C C *** exit CALL STSEPI END