C----------------------------------------------------------------------- C; Copyright (C) 1995, 1996 C; Associated Universities, Inc. Washington DC, USA. 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 Massachusetts Ave, Cambridge, C; MA 02139, USA. C C For further information about this software contact: C Internet email: bcotton@nrao.edu. C Postal address: Bill Cotton C National Radio Astronomy Observatory C 520 Edgemont Road C Charlottesville, VA 22903-2475 USA C----------------------------------------------------------------------- SUBROUTINE VLINI (FILE, VERS, HDNO, UNIT, NROWS, VLKOLS, * BEAM, SORT, NUMINX, INDEX, DATE, IERR) C----------------------------------------------------------------------- C Open for read an AIPS VL (NVSS catalog) table from FITS file C Inputs: C FILE C*? Name of disk FITS file C VERS I VL table version C Input/Output: C HDNO I HDU number, if 0 on input it will be determined C Output: C UNIT I Fortran I/O unit number C NROWS I Number of rows C VLKOLS I(*) Array of column numbers for table entries C BEAM R(3) Restoring beam parameters, maj, min, pa in deg. C SORT I Column number for sort (neg -> descending), Used C only to create. More reliable that the AIPS table C sort indicators as they are lost when the file is C written to FITS. C NUMINX I Number of rows in table when indexed. Used to C determine if index is still valid; if not INDEX is C filled with -1. C INDEX I(24)Index table giving the first row number with RA C greater than RA, for each hour of RA. -1 = > no C index. Initialized to -1s on create. Also -1s C returned if data unsorted. C Output: C DATE C*? Creation date of FITS file (dd/mm/yy). C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER MAXCOL C MAXCOL = max number cols. PARAMETER (MAXCOL=18) CHARACTER FILE*(*), DATE*(*) REAL BEAM(3) INTEGER VERS, HDNO, UNIT, NROWS, VLKOLS(MAXCOL), SORT, NUMINX, * INDEX(24), IERR C INTEGER STATUS, READWR, BLOCK, HTYPE, IVALUE, I CHARACTER KEYW*8, VALUE*70, COMMNT*70, CTYPE(MAXCOL)*24, AIPSVL*8 C 1 2 DATA CTYPE / 'RA(2000)', 'DEC(2000)', C 3 4 5 6 * 'PEAK INT', 'MAJOR AX', 'MINOR AX', 'POSANGLE', C 7 8 9 * 'Q CENTER', 'U CENTER', 'P FLUX', C 10 11 * 'I RMS ', 'POL RMS ', C 12 13 14 * 'RES RMS ', 'RES PEAK', 'RES FLUX', C 15 16 * 'CENTER X', 'CENTER Y', C 17 18 * 'FIELD', 'JD PROCESSED'/ DATA AIPSVL /'AIPS VL '/ C----------------------------------------------------------------------- STATUS = 0 C Set unit number CALL FTGIOU (UNIT, STATUS) C Read only READWR = 0 C Open CALL FTOPEN (UNIT, FILE, READWR, BLOCK, STATUS) C Get creation date DATE = 'Unknown' CALL FTGKYS (UNIT,'DATE ', DATE, COMMNT, STATUS) C Need to find which HDU? IF (HDNO.LE.0) THEN 100 CALL FTMRHD (UNIT, 1, HTYPE, STATUS) C Error? IF (STATUS.NE.0) GO TO 110 C Is this a binary table? IF (HTYPE.NE.2) GO TO 100 C Is this a VL table? KEYW = 'EXTNAME' CALL FTGKEY(UNIT, KEYW, VALUE, COMMNT, STATUS) IF (STATUS.NE.0) GO TO 110 IF (VALUE(2:9).NE.AIPSVL) GO TO 100 C Correct version number? KEYW = 'EXTVER' CALL FTGKYJ(UNIT, KEYW, IVALUE, COMMNT, STATUS) IF (STATUS.NE.0) GO TO 110 IF (IVALUE.NE.VERS) GO TO 100 C Found it - where are we? CALL FTGHDN (UNIT, IVALUE) HDNO = IVALUE ELSE C Go to correct HDU CALL FTMAHD(UNIT, HDNO, HTYPE, STATUS) END IF C Consistency checks 110 IVALUE = 0 KEYW = 'TFIELDS' CALL FTGKYJ(UNIT, KEYW, IVALUE, COMMNT, STATUS) C Should be 18 Fields IF (IVALUE.NE.18) THEN WRITE (0,1000) IVALUE, STATUS 1000 FORMAT ('Problem with TFIELDS =',I4,' not 18, status = ',I4) IERR = STATUS GO TO 999 END IF C Consistency checks IVALUE = 0 KEYW = 'REVISION' CALL FTGKYJ(UNIT, KEYW, IVALUE, COMMNT, STATUS) C Should be Revision number 1 IF (IVALUE.NE.1) THEN WRITE (0,1001) IVALUE, STATUS 1001 FORMAT ('Problem with REVISION =',I4,' not 1, status = ',I4) IERR = 2 GO TO 999 END IF C Get header info. C Number of rows CALL FTGKYJ (UNIT, 'NAXIS2 ', NROWS, COMMNT, STATUS) C Beam CALL FTGKYE (UNIT, 'BM_MAJOR', BEAM(1), COMMNT, STATUS) CALL FTGKYE (UNIT, 'BM_MINOR', BEAM(2), COMMNT, STATUS) CALL FTGKYE (UNIT, 'BM_PA ', BEAM(3), COMMNT, STATUS) C Sort column CALL FTGKYJ (UNIT, 'SORTORT ', SORT, COMMNT, STATUS) C Number when indexed CALL FTGKYJ (UNIT, 'NUM_INDE', NUMINX, COMMNT, STATUS) C Index table CALL FTGKNJ (UNIT, 'INDEX', 0, 24, INDEX, IVALUE, STATUS) IF (IVALUE.NE.24) THEN WRITE (0,1002) IVALUE, STATUS 1002 FORMAT ('Problem with INDEX =',I4,' not 24, status = ',I4) IERR = 3 GO TO 999 END IF C Get column numbers DO 200 I = 1,MAXCOL CALL FTGCNO (UNIT, .TRUE., CTYPE(I), VLKOLS(I), STATUS) 200 CONTINUE C set status IERR = STATUS 999 RETURN END SUBROUTINE VLTAB (UNIT, OPCODE, VLROW, VLKOLS, FBLANK, * RA2000, DE2000, PEAK, MAJOR, MINOR, POSANG, * QCENT, UCENT, PFLUX, * IRMS, PRMS, RESRMS, RESPEK, RESFLX, * CENX, CENY, FIELD, JDPRO, * IERR) C----------------------------------------------------------------------- C Read a VL table entry. C Inputs: C UNIT I Fortran I/O unit number C OPCODE C*4 Open 'READ' or 'CLOS' C VLROW I Row in table. C VLKOLS I(*) Array of column numbers for table entries C FBLANK R REAL magic value blanking value C Input/output(all angles in degrees) C RA2000 D RA (2000) C DE2000 D Dec (2000) C PEAK R Peak Ipol C MAJOR R Fitted major axis size C MINOR R Fitted minor axis size C POSANG R Fitted PA C QCENT R Center Q flux density C UCENT R Center U flux density C PFLUX R Integrated polarized flux density C IRMS R RMS (sigma) in Ipol. C PRMS R RMS (sigma) in Qpol and Upol. C RESRMS R RMS of Ipol residual C RESPEK R Peak in Ipol residual C RESFLX R Integrated Ipol residual C CENX R Center x position in pixels in FIELD C CENY R Center y position in pixels in FIELD C FIELD C*8 Name of survey field C JDPRO I Julian date on which entry was derived from image. C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER MAXCOL C MAXCOL = max number cols. PARAMETER (MAXCOL=18) CHARACTER OPCODE*4 INTEGER UNIT, VLROW, VLKOLS(MAXCOL), JDPRO, IERR DOUBLE PRECISION RA2000, DE2000 REAL FBLANK, PEAK, MAJOR, MINOR, POSANG REAL QCENT, UCENT, PFLUX REAL IRMS, PRMS, RESRMS, RESPEK, RESFLX REAL CENX, CENY CHARACTER FIELD*8 C INTEGER NUM, IEL, IC, STATUS, IROW LOGICAL ANYF CHARACTER CDATA(1)*8 C----------------------------------------------------------------------- IERR = 0 STATUS = 0 C Close? IF (OPCODE.EQ.'CLOS') THEN CALL FTCLOS (UNIT, STATUS) IERR = STATUS CALL FTFIOU (UNIT, STATUS) GO TO 999 END IF C Row number IROW = VLROW IEL = 1 NUM = 1 IC = 1 C RA2000 CALL FTGCVD (UNIT, VLKOLS(IC), IROW, IEL, NUM, 0.0D0, RA2000, * ANYF, STATUS) IC = IC + 1 C DE2000 CALL FTGCVD (UNIT, VLKOLS(IC), IROW, IEL, NUM, 0.0D0, DE2000, * ANYF, STATUS) IC = IC + 1 C PEAK CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, PEAK, * ANYF, STATUS) IC = IC + 1 C MAJOR CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, MAJOR, * ANYF, STATUS) IC = IC + 1 C MINOR CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, MINOR, * ANYF, STATUS) IC = IC + 1 C POSANG CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, POSANG, * ANYF, STATUS) IC = IC + 1 C QCENT CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, QCENT, * ANYF, STATUS) IC = IC + 1 C UCENT CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, UCENT, * ANYF, STATUS) IC = IC + 1 C PFLUX CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, PFLUX, * ANYF, STATUS) IC = IC + 1 C IRMS CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, IRMS, * ANYF, STATUS) IC = IC + 1 C PRMS CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, PRMS, * ANYF, STATUS) IC = IC + 1 C RESRMS CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, RESRMS, * ANYF, STATUS) IC = IC + 1 C RESPEK CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, RESPEK, * ANYF, STATUS) IC = IC + 1 C RESFLX CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, RESFLX, * ANYF, STATUS) IC = IC + 1 C CENX CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, CENX, * ANYF, STATUS) IC = IC + 1 C CENY CALL FTGCVE (UNIT, VLKOLS(IC), IROW, IEL, NUM, FBLANK, CENY, * ANYF, STATUS) IC = IC + 1 C FIELD C NUM = LEN(FIELD) CALL FTGCVS (UNIT, VLKOLS(IC), IROW, IEL, NUM, ' ', CDATA, * ANYF, STATUS) FIELD = CDATA(1) IC = IC + 1 C JDPRO C NUM = 1 CALL FTGCVJ (UNIT, VLKOLS(IC), IROW, IEL, NUM, 0, JDPRO, ANYF, * STATUS) C Flagged entry? IERR = STATUS IF (ANYF) IERR = -1 C 999 RETURN END