C----------------------------------------------------------------------- C; Copyright (C) 1995 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----------------------------------------------------------------------- LOCAL INCLUDE 'NVSSLIST.INC' C Program global common C FITS file name CHARACTER FTFILE*80 C AIPS VL version number INTEGER VER C HDU number for fitsio INTEGER HDNUM C Unit number for fitsio INTEGER HDUNIT C Output file CHARACTER PRNAME*80 C Object label CHARACTER LABEL*50 C Width of line of output INTEGER WIDTH C Lines in interactive "page" INTEGER NLINT C Lines in file "page" INTEGER NLFILE C Epoch/equinox code C 1=1900, 2=B1950, 3=J2000 INTEGER EPOCOD C Show fitted values flag LOGICAL FITTED C Parameter array REAL PARM(12) COMMON /NVSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED COMMON /NVSSCH/ FTFILE, PRNAME, LABEL LOCAL END LOCAL INCLUDE 'TEXTCOM.INC' C Local include for text file C common. CHARACTER FILNAM*48, LINE*80 INTEGER TXUNIT LOGICAL INIT, ISOPEN COMMON /TFILCM/ INIT, ISOPEN, TXUNIT COMMON /CFILCM/ FILNAM, LINE LOCAL END PROGRAM VLIST C----------------------------------------------------------------------- C Program to display selected values from an NVSS catalog as an C AIPS VL binary table extension to a FITS file. C----------------------------------------------------------------------- INTEGER IRET, JERR DOUBLE PRECISION RA, DEC, SEARCH, BOX(2) REAL MINFLX, MINPOL LOGICAL FIRST, LAST INCLUDE 'NVSSLIST.INC' INCLUDE 'TEXTCOM.INC' C----------------------------------------------------------------------- C Startup CALL VLSUIN (IRET) IF (IRET.NE.0) GO TO 990 FIRST = .TRUE. INIT = .TRUE. C Loop over positions 100 CALL NXTPOS (LAST, RA, DEC, SEARCH, BOX, MINFLX, MINPOL, IRET) IF (IRET.NE.0) GO TO 990 C Print selected portion of table CALL PRTVLT (FIRST, LAST, RA, DEC, SEARCH, BOX, MINFLX, * MINPOL, IRET) IF (IRET.NE.0) GO TO 990 FIRST = .FALSE. C More? IF (.NOT.LAST) GO TO 100 C Close down files, etc. 990 CALL TXCLS (TXUNIT, JERR) C 999 STOP END SUBROUTINE VLSUIN (IERR) C----------------------------------------------------------------------- C VLSUIN gets input parameters for VLIST. C Input lines may include trailing comments delimited by "!" C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C INTEGER I, I1, I2, MAXCAR, CTRIM, ITRIM, KBP, COUNT LOGICAL EXISTS REAL SEC CHARACTER SIGN*1, ILINE*132, HLPFIL*12, CFGDIR*68, FULFIL*80 DOUBLE PRECISION XVALUE INCLUDE 'NVSSLIST.INC' INCLUDE 'TEXTCOM.INC' DATA HLPFIL /'NVSSlist.hlp'/ C----------------------------------------------------------------------- IERR = 0 HDNUM = 0 C Init values DO 10 I = 1,12 PARM(I) = 0.0 10 CONTINUE C Instructions WRITE(6,1000) * 'Browser for NVSS radio source list', * 'Version 1.1, report problems to bcotton@nrao.edu' C Get installation directory CALL GETDIR (CFGDIR) FULFIL = CFGDIR(1:ITRIM(CFGDIR)) // HLPFIL C See if file exists in local C directory INQUIRE (FILE=FULFIL, EXIST=EXISTS) IF (EXISTS) THEN WRITE (6,1000) 'For details of NVSSlist see', FULFIL END IF C Get configuration CALL GETCFG (IERR) IF (IERR.NE.0) GO TO 999 C Some instructions WRITE(6,1000) ' ', * 'A reply of ? will give a short explanation of the question.', * 'A blank reply will invoke the [default]' C Listing File name 100 WRITE(6,1000) 'Enter any output file name [terminal]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (1) GO TO 100 END IF PRNAME = ILINE(1:CTRIM(ILINE)) C Field list file name COUNT = 1 110 WRITE(6,1000) 'Enter any input field list file name [ask]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (2) GO TO 110 END IF FILNAM = ILINE(1:CTRIM(ILINE)) C Make sure it exists EXISTS = .TRUE. IF (FILNAM.NE. ' ') INQUIRE (FILE=FILNAM, EXIST=EXISTS) IF (.NOT.EXISTS) THEN COUNT = COUNT + 1 C Standard defaults WRITE (0,1000) FILNAM // ' not found' C 10 strikes and you're out IF (COUNT.LT.10) THEN GO TO 110 ELSE FILNAM = ' ' END IF END IF C Equinox 120 WRITE(6,1000) 'Enter equinox code 1=B1900, 2=B1950,' // * ' 3=J2000 [3]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (3) GO TO 120 END IF IF (ILINE.EQ.' ') THEN EPOCOD = 3 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) EPOCOD = XVALUE + 0.5D0 END IF C Deconvolved 130 WRITE(6,1000) 'Enter 0=Deconvolved, 1=Fitted values [0]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (4) GO TO 130 END IF IF (ILINE.EQ.' ') THEN FITTED = .FALSE. ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I1 = XVALUE + 0.5D0 FITTED = I1.EQ.1 END IF C Min flux density 140 WRITE(6,1000) 'Enter Minimum flux density (Jy) [0]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (5) GO TO 140 END IF IF (ILINE.EQ.' ') THEN PARM(8) = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(8) = XVALUE END IF C Min percent pol. 150 WRITE(6,1000) 'Enter Minimum percent pol. flux density [0]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (6) GO TO 150 END IF IF (ILINE.EQ.' ') THEN PARM(9) = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(9) = XVALUE END IF C Get source info if not using a C file. IF (FILNAM.EQ.' ') THEN C Field label 160 WRITE(6,1000) 'Enter object name [none]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (7) GO TO 160 END IF LABEL = ILINE(1:CTRIM(ILINE)) C RA 170 WRITE(6,1000) 'Enter central RA (hh mm ss.ss) [0 0 0]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (8) GO TO 170 END IF IF (ILINE.EQ.' ') THEN I1 = 0 I2 = 0 SEC = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I1 = XVALUE + 0.5D0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I2 = XVALUE + 0.5D0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) SEC= XVALUE END IF PARM(1) = I1 PARM(2) = I2 PARM(3) = SEC C Declination 180 WRITE(6,1000) 'Enter central Dec (sdd mm ss.s)[0 0 0]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (9) GO TO 180 END IF SIGN = ' ' IF (ILINE.EQ.' ') THEN I1 = 0 I2 = 0 SEC = 0.0 ELSE I1 = INDEX (ILINE, '-') IF (I1.GT.0) SIGN = '-' MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I1 = ABS(XVALUE) + 0.5D0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I2 = XVALUE + 0.5D0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) SEC= XVALUE END IF PARM(4) = I1 PARM(5) = I2 PARM(6) = SEC IF (SIGN.EQ.'-') PARM(4) = -PARM(4) IF ((SIGN.EQ.'-') .AND. (PARM(4).EQ.0.0)) PARM(5) = -PARM(5) C Search radius 190 WRITE(6,1000) 'Search radius in degrees [180]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (10) GO TO 190 END IF IF (ILINE.EQ.' ') THEN PARM(7) = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(7) = XVALUE END IF C Search box 200 WRITE(6,1000) 'Search box halfwidth in hr,deg [12,180]' READ(5,1000,ERR=900,END=900) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (11) GO TO 200 END IF IF (ILINE.EQ.' ') THEN PARM(11) = 0.0 PARM(12) = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) C Convert to degrees PARM(11) = XVALUE * 15.0D0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(12) = XVALUE END IF END IF GO TO 999 C Error 900 WRITE (0,1000) 'Error reading selection values ' IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE HELPME (CODE) C----------------------------------------------------------------------- C Gives short description of the question in response to a user ? C Inputs: C CODE I Index of help information C----------------------------------------------------------------------- INTEGER CODE C----------------------------------------------------------------------- C Output file IF (CODE.EQ.1) THEN WRITE(6,1000) * 'If the name of a file is given then the output will be', * 'appended to the end of this file; otherwise output will be', * 'to the terminal.', * ' ' C Field list ELSE IF (CODE.EQ.2) THEN WRITE(6,1000) * 'A list of fields to be searched can be given in a text file.', * 'See README for a description of this file', * ' ' C Equinox ELSE IF (CODE.EQ.3) THEN WRITE(6,1000) * 'This is the equinox of the coordinates to be used for all', * 'input and output.', * ' ' C Deconvolved ELSE IF (CODE.EQ.4) THEN WRITE(6,1000) * 'Deconvolved gives deconvolved component size, integrated', * 'flux density. Fitted gives fitted component size, peak flux', * ' density.', * ' ' C Min. flux density ELSE IF (CODE.EQ.5) THEN WRITE(6,1000) * 'Only sources with a peak brightness (Jy) higher than this', * 'value will be listed.', * ' ' C Min. percent pol ELSE IF (CODE.EQ.6) THEN WRITE(6,1000) * 'Only sources with a percentage polarization higher than', * 'this value will be listed.', * ' ' C Field label ELSE IF (CODE.EQ.7) THEN WRITE(6,1000) * 'This string gives a label for this field in the output.', * ' ' C RA ELSE IF (CODE.EQ.8) THEN WRITE(6,1000) * 'The listing can be limited to a specified region in RA-Dec', * 'The center RA is given as hh mm ss.s.', * 'A search radius or box size must also be specified.', * ' ' C DEC ELSE IF (CODE.EQ.9) THEN WRITE(6,1000) * 'The listing can be limited to a specified region in RA-Dec', * 'The center Dec is given as +/-dd mm ss.s.', * 'A search radius or box size must also be specified.', * ' ' C Search radius ELSE IF (CODE.EQ.10) THEN WRITE(6,1000) * 'The radius of the specified circular region about the center', * 'RA and declination is given in degrees.', * ' ', * ' ' C Box size ELSE IF (CODE.EQ.11) THEN WRITE(6,1000) * 'The halfwidths of the specified rectangular region about the', * ' center RA and declination are given in hours of RA and deg.', * 'of dec: RA_halfwidth, Dec_halfwidth', * ' ' END IF C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE GETCFG (IERR) C----------------------------------------------------------------------- C GETCFG reads any values from configuration (NVSSlist.cfg) or sets C defaults. Configuration file contains the following C line 1: CATALOG.FIT ! Name of FITS file C line 2: 1 ! VL table version C Line 3: 132 ! Width of output in characters C Line 4: 24 ! Number of lines in interactive "page" C Line 5: 55 ! Number of lines in "page" for file output C The format of the line is free format and optional comments are C allowed after a "!". C The current directory is searched first and if the configuration C file is not found, CFGDIR is called to find the directory in which C the site master NVSSlist.cfg file was installed. If the file isn't C found or the entry is blank the standard values will be used. C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C INTEGER I, CTRIM, ITRIM, KBP, UNIT LOGICAL EXISTS CHARACTER ILINE*132, CFGFIL*12, CFGDIR*68, FULFIL*80 DOUBLE PRECISION XVALUE INCLUDE 'NVSSLIST.INC' INCLUDE 'TEXTCOM.INC' DATA CFGFIL /'NVSSlist.cfg'/ C----------------------------------------------------------------------- IERR = 0 C Standard defaults FTFILE = 'CATALOG.FIT' VER = 1 WIDTH = 132 NLINT = 24 NLFILE = 50 C See if file exists in local C directory FULFIL = CFGFIL INQUIRE (FILE=FULFIL, EXIST=EXISTS) IF (EXISTS) GO TO 100 C check site master CALL GETDIR (CFGDIR) FULFIL = CFGDIR(1:ITRIM(CFGDIR)) // CFGFIL C See if file exists. INQUIRE (FILE=FULFIL, EXIST=EXISTS) IF (.NOT.EXISTS) THEN C Standard defaults WRITE (0,1000) CFGFIL, * ' not found; will use standard defaults' GO TO 999 END IF C Open 100 UNIT = 12 ILINE = 'File not yet open' CALL TXOPN (UNIT, FULFIL, IERR) IF (IERR.NE.0) GO TO 900 C FITS File name CALL TXREAD (UNIT, ILINE, IERR) IF (IERR.LT.0) GO TO 800 IF (IERR.GT.0) GO TO 900 IF (ILINE.NE.' ') THEN FTFILE = ILINE(1:CTRIM(ILINE)) END IF C Version CALL TXREAD (UNIT, ILINE, IERR) IF (IERR.LT.0) GO TO 800 IF (IERR.GT.0) GO TO 900 IF (ILINE.NE.' ') THEN I = CTRIM (ILINE) KBP = 1 CALL GETNUM (ILINE, I, KBP, XVALUE) VER = XVALUE + 0.5D0 END IF C Output width CALL TXREAD (UNIT, ILINE, IERR) IF (IERR.LT.0) GO TO 800 IF (IERR.GT.0) GO TO 900 IF (ILINE.NE.' ') THEN KBP = 1 I = CTRIM (ILINE) CALL GETNUM (ILINE, I, KBP, XVALUE) WIDTH = XVALUE + 0.5D0 END IF C Interactive page size CALL TXREAD (UNIT, ILINE, IERR) IF (IERR.LT.0) GO TO 800 IF (IERR.GT.0) GO TO 900 IF (ILINE.NE.' ') THEN KBP = 1 I = CTRIM (ILINE) CALL GETNUM (ILINE, I, KBP, XVALUE) NLINT = XVALUE + 0.5D0 END IF C File page size CALL TXREAD (UNIT, ILINE, IERR) IF (IERR.LT.0) GO TO 800 IF (IERR.GT.0) GO TO 900 IF (ILINE.NE.' ') THEN KBP = 1 I = CTRIM (ILINE) CALL GETNUM (ILINE, I, KBP, XVALUE) NLFILE = XVALUE + 0.5D0 END IF C Close config file. CALL TXCLS (UNIT, IERR) IF (IERR.NE.0) GO TO 900 C Tell config file WRITE (6,1000) 'Setup from configuration file:', FULFIL GO TO 999 C End of file 800 WRITE (0,1000) 'ERROR too few entries in configuration file:', * FULFIL IERR = 4 GO TO 999 C Error 900 WRITE (0,1000) 'ERROR reading configuration file ', * ' Current line is:', ILINE IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE NXTPOS (LAST, RA, DEC, SEARCH, BOX, MINFLX, MINPOL, * IERR) C----------------------------------------------------------------------- C Get info for next search position. Uses/stores information in C common in TEXTCOM.INC C Inputs: C Output: C LAST L If true returned position is the last one. C RA D RA center of search, degrees in J2000 C DEC D Dec center of search, degrees in J2000 C SEARCH D Search radius in deg, <= 0 => all selected. C BOX D(2) RA and Dec halfwidth of search rectangle C MINFLX R Minimum peak flux density. C MINPOL R Minimum percent integrated polarization C IERR I Error code: 0 => ok C----------------------------------------------------------------------- LOGICAL LAST DOUBLE PRECISION RA, DEC, SEARCH, BOX(2) REAL MINFLX, MINPOL INTEGER IERR C CHARACTER CRDNAM(3)*40 DOUBLE PRECISION CRDPRM(11), ROTN, RAT, DECT INCLUDE 'NVSSLIST.INC' INCLUDE 'TEXTCOM.INC' DATA CRDNAM /'EQUATORIAL b1900.0', 'EQUATORIAL b1950.0', * 'EQUATORIAL J2000.0'/ C----------------------------------------------------------------------- C Source selection from adverbs MINFLX = PARM(8) MINPOL = PARM(9) BOX(1) = PARM(11) BOX(2) = PARM(12) C Need to init? IF (INIT) THEN INIT = .FALSE. C Interactive or file input? IF (FILNAM.EQ.' ') THEN C Interactive input LAST = .TRUE. SEARCH = PARM(7) RA = 15.0D0 * (PARM(1) + PARM(2)/60.0D0 + PARM(3)/3600.0D0) DEC = ABS (PARM(4)) + ABS(PARM(5))/60.0D0 + * ABS (PARM(6))/3600.0D0 IF ((PARM(4).LT.0.0) .OR. (PARM(5).LT.0.0) .OR. * (PARM(6).LT.0.0)) DEC = - DEC GO TO 500 ELSE C File input TXUNIT = 10 CALL TXOPN (TXUNIT, FILNAM, IERR) IF (IERR.NE.0) THEN WRITE (0,1020) IERR, FILNAM GO TO 999 END IF ISOPEN = .TRUE. C First entry CALL TXREAD (TXUNIT, LINE, IERR) IF (IERR.NE.0) THEN WRITE (0,1100) IERR, FILNAM GO TO 999 END IF END IF C End of init END IF C Decode line CALL STCARD (LINE, RA, DEC, SEARCH, LABEL, IERR) IF (IERR.NE.0) THEN WRITE (0,1101) 'ERROR Parsing source list line:' WRITE (0,1101) LINE GO TO 999 END IF C Next entry CALL TXREAD (TXUNIT, LINE, IERR) LAST = (LINE.EQ.' ') .OR. (IERR.EQ.-1) IF (IERR.EQ.-1) IERR = 0 IF (IERR.NE.0) THEN WRITE (0,1100) IERR, FILNAM GO TO 999 END IF C Need to change epoch? 500 IF ((EPOCOD.EQ.1) .OR. (EPOCOD.EQ.2)) THEN CALL CRDSET (CRDNAM(EPOCOD), CRDNAM(3), CRDPRM, IERR) IF (IERR.NE.0) GO TO 999 CALL CRDTRN (RA, DEC, CRDPRM, RAT, DECT, ROTN) RA = RAT DEC = DECT END IF IERR = 0 C 999 RETURN C----------------------------------------------------------------------- 1020 FORMAT ('ERROR',I4,' Opening source list file:',A) 1100 FORMAT ('ERROR',I4,' Reading source list file:',A) 1101 FORMAT (A) END SUBROUTINE PRTVLT (FIRST, LAST, RA, DEC, SEARCH, BOX, * MINFLX, MINPOL, IERR) C----------------------------------------------------------------------- C Print selected entries. C Inputs: C FIRST L First call? open printer C LAST L Last call? close printer when done. C RA D RA center of search, degrees in J2000 C DEC D Dec center of search, degrees in J2000 C SEARCH D Search radius in deg, <= 0 => all selected. C BOX D(2) RA and Dec halfwidth of search rectangle C MINFLX R Minimum peak flux density. C MINPOL R Minimum percent integrated polarization C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- DOUBLE PRECISION RA, DEC, SEARCH, BOX(2) LOGICAL FIRST, LAST INTEGER IERR REAL MINFLX, MINPOL, FBLANK C INTEGER NROW, IROW, IR, BC, EC, INC, IEL, NUM, * RAHM(2), DECDM(2), SORT, NUMIND, INDEX(25), BCINDX, ECINDX, * IRAB, IRAE, IPASS, NPASS, BEG(2), END(2), BCI, ECI, IMARK, IER, * NUMCOL, JDPRO, VLKOLS(50), PAGE, LPAGE, PRUNIT, PAGENO, SCOUNT REAL RAS, DECS, BEAM(3), CUTT, TCUT, FLUX, * EFLUX, EPFLUX, ERRRA, ERRDEC, PCTPOL LOGICAL WANTED, INDXED, DOALL, SELECT, QUIT, NORAD, NOBOX, ANYF, * FOUND CHARACTER LINE*132, ELINE*132, TIT1*132, TIT2*132, * DSIG*1, MARK(4)*2, DISYM*1 CHARACTER CMAJOR*6, CMINOR*6, CPA*6, EMAJOR*6, EMINOR*6, EPA*6, * CRDNAM(3)*40, CHPANG*6, CHEPAN*6, CDIST*6 DOUBLE PRECISION RAC, DECC, RA0, DEC0, RAR, DECR, RAB, RAE, * L, M, RADIUS, RADR, DIST, RABEG, RAEND, DECBEG, DECEND, DISCL, * CRDPRM(11), ROTN, RAT, DECT, DIST2, RADR2, BOXRA, BOXDEC, ODISCL DOUBLE PRECISION RA2000, DE2000 REAL PEAK, MAJOR, MINOR, POSANG REAL QCENT, UCENT, PFLUX REAL IRMS, PRMS, RESRMS, RESPEK, RESFLX REAL CENX, CENY CHARACTER FIELD*8 INCLUDE 'NVSSLIST.INC' DOUBLE PRECISION DG2RAD C Degrees per radian PARAMETER (DG2RAD = 1.745329252E-2) DATA MARK /' ', 'R*', 'P*', 'S*'/ C Survey minimum residual DATA CUTT /0.002/ DATA CRDNAM /'EQUATORIAL b1900.0', 'EQUATORIAL b1950.0', * 'EQUATORIAL J2000.0'/ C Blanking value DATA FBLANK /1.23456E20/ SAVE PAGE, PAGENO, PRUNIT, LPAGE, SCOUNT, TIT1, TIT2 C----------------------------------------------------------------------- C Setup/Open output FOUND = .FALSE. C Check declination IF (DEC.LT.-40.0) THEN WRITE(0,2000) 'The NVSS only goes south to declination -40!' IERR = 9 GO TO 999 END IF C Output line limit NUMCOL = WIDTH C "Interactive" output? IF (PRNAME.EQ.' ') THEN PRUNIT = 6 LPAGE = NLINT ELSE PRUNIT = 11 LPAGE = NLFILE END IF IF (FIRST) THEN C Reset page titles TIT1 = ' ' TIT2 = ' ' SCOUNT = 0 PAGE = 1 PAGENO = 1 ODISCL = 0.0D0 C Open output CALL PRTOPN (PRNAME, PRUNIT, IERR) IF (IERR.NE.0) GO TO 990 C Print info LINE = 'NRAO/VLA Sky Survey (NVSS) Catalog search, ver 1.1' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 710 LINE = 'Error estimates appear below the value.' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (QUIT) GO TO 710 WRITE (LINE,3000) VER CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 710 CALL PRTWRI (PRUNIT, FTFILE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 710 END IF C Calibration component of C Open input table CALL VLINI (FTFILE, VER, HDNUM, HDUNIT, NROW, VLKOLS, BEAM, * SORT, NUMIND, INDEX, IERR) IF (IERR.NE.0) THEN WRITE(0,2000) 'ERROR opening input FITS VL table ' // FTFILE CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF IF (BEAM(1).LE.0.0) BEAM(1) = 45.0 / 3600.0 IF (BEAM(2).LE.0.0) BEAM(2) = 45.0 / 3600.0 C Get transformation constants IF ((EPOCOD.EQ.1) .OR. (EPOCOD.EQ.2)) THEN CALL CRDSET (CRDNAM(3), CRDNAM(EPOCOD), CRDPRM, IERR) IF (IERR.NE.0) THEN WRITE (0,2000) 'ERROR initializing coordinate transform' GO TO 999 END IF END IF C Rows to copy BCI = 1 ECI = NROW IF (BCI.LE.0) BCI = 1 IF (ECI.LE.0) ECI = NROW ECI = MAX (BCI, ECI) INC = 1 IF (INC.LE.0) INC = 1 C Position search box RAC = RA DECC = DEC RA0 = RAC * DG2RAD DEC0 = DECC * DG2RAD RADIUS = SEARCH C Search window? DOALL = (RADIUS.EQ.0.0) .AND. (BOX(1).LE.0.0D0) .AND. * (BOX(2).LE.0.0D0) C No radius specified? NORAD = RADIUS.LE.0.0 IF (NORAD) RADIUS = MAX (BOX(1), BOX(2)) RADR = RADIUS * DG2RAD RADR2 = RADR * RADR C No Box? NOBOX = ((BOX(1).LE.0.0) .AND. (BOX(2).LE.0.0)) IF (BOX(1).LE.0.0) BOX(1) = MAX (BOX(1), BOX(2), RADIUS) IF (BOX(2).LE.0.0) BOX(2) = MAX (BOX(1), BOX(2), RADIUS) C RA box fullwidth in hours BOXRA = 2.0D0 * BOX(1) / 15.0D0 BOXDEC = 2.0D0 * BOX(2) C Radius scaling IF (RADIUS.LE.0.3) THEN DISCL = 3600.0D0 DISYM = '"' ELSE IF (RADIUS.LE.10.0) THEN DISCL = 60.0D0 DISYM = '''' ELSE DISCL = 1.0D0 DISYM = 'o' END IF C All positions IF (DOALL) THEN DECBEG = -100 DECEND = 100 BCINDX = 1 ECINDX = NROW NPASS = 1 BEG(1) = BCINDX END(1) = ECINDX RAB = 0.0 RAE = 360.0 ELSE C Select position range DECBEG = DECC - BOX(2) DECEND = DECC + BOX(2) RAB = RAC - (MIN (RADIUS, BOX(1)) / COS (DECC * DG2RAD)) IF (RAB.LT.0.0) RAB = RAB + 360.0 RAE = RAC + (MIN (RADIUS, BOX(1)) / COS (DECC * DG2RAD)) IF (RAE.GT.360.0) RAE = RAE - 360.0 IRAB = RAB / 15.0 IRAE = RAE / 15.0 IRAB = MIN (23, MAX (0, IRAB)) IRAE = MIN (24, MAX (0, IRAE)) INDEX(25) = NROW C Table indexed? INDXED = INDEX(1).GT.0 IF (INDXED) THEN BCINDX = INDEX(IRAB+1) ECINDX = INDEX(IRAE+2) ELSE BCINDX = 1 ECINDX = NROW END IF C It takes two passes for wrap in C RA range. IF (IRAB.GT.IRAE) THEN NPASS = 2 BEG(1) = BCINDX END(1) = NROW BEG(2) = 1 END(2) = ECINDX ELSE NPASS = 1 BEG(1) = BCINDX END(1) = ECINDX END IF END IF C Tell selection criteria IF (FIRST) THEN C Minimum flux density IF (MINFLX.GT.1.0E-5) THEN WRITE (LINE,1002) MINFLX CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 END IF C Minimum percentage pol. IF (MINPOL.GT.1.0E-5) THEN WRITE (LINE,1003) MINPOL CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 END IF IF (.NOT.DOALL) THEN IF (INDXED) THEN LINE = 'Table Indexed for faster access' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 ELSE LINE = 'NOTE:Table NOT Indexed' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 END IF END IF C Show fitted/deconvolved sizes? IF (FITTED) THEN LINE = 'Displaying fitted component size, peak flux density' ELSE LINE = 'Displaying deconvolved component size,' // * ' integrated flux density' END IF CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (QUIT) GO TO 700 IF (IERR.NE.0) GO TO 990 C Res codes LINE = 'Residual (Res) code; nonblank indicates complex ' // * 'source structure:' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (QUIT) GO TO 700 IF (IERR.NE.0) GO TO 990 LINE = ' P* => high peak, R* => high RMS,' // * ' S* => high integral' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (QUIT) GO TO 700 IF (IERR.NE.0) GO TO 990 LINE = ' ' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 END IF IF (.NOT.DOALL) THEN C Need to change epoch? IF ((EPOCOD.EQ.1) .OR. (EPOCOD.EQ.2)) THEN CALL CRDTRN (RAC, DECC, CRDPRM, RAT, DECT, ROTN) ELSE RAT = RAC DECT = DEC END IF C Position at input equinox CALL COORDD (1, RAT, DSIG, RAHM, RAS) CALL COORDD (2, DECT, DSIG, DECDM, DECS) IF (.NOT.FIRST) THEN LINE = ' ' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF C Object label IF (LABEL.NE.' ') THEN LINE = 'Search for object: ' // LABEL CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO,QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF IF (.NOT.NORAD) THEN WRITE (LINE,1000) RADIUS, RAHM, RAS, DSIG, DECDM, DECS CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF IF (.NOT.NOBOX) THEN WRITE (LINE,1004) BOXRA, BOXDEC, RAHM, RAS, DSIG, DECDM, * DECS CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF IF (FIRST) THEN LINE = ' ' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF END IF C Page labels IF (.NOT.DOALL) THEN IF (NUMCOL.LT.93) NUMCOL = 70 C Default with pos select C xx xx xx.xx +xx xx xx.x xxx.x xxxx.x xxx.x xxx.x TIT1 = ' RA(2000) Dec(2000) Dist Flux Major Minor' // C xx.x c xxxx.x -xx.x J0000+00 1234.5 1234.5 * ' PA Res P_Flux P_ang Field X_pix Y_pix' IF (FITTED) TIT1(32:35) = 'Peak' C xx xx xx.xx +xx xx xx.x xxx.x xxxx.x xxx.x xxx.x TIT2 = ' h m s d m s " mJy " " ' // C xx.x c xxxx.x -xx.x * ' deg mJy deg' C Unist symbol for distance TIT2(28:28) = DISYM ELSE IF (NUMCOL.LT.87) NUMCOL = 64 C Default listing C xx xx xx.xx +xx xx xx.x xxxx.x xxx.x xxx.x TIT1 = ' RA(2000) Dec(2000) Flux Major Minor' // C xx.x c xxxx.x -xx.x J0000+00 1234.5 1234.5 * ' PA Res P_Flux P_ang Field X_pix Y_pix ' IF (FITTED) TIT1(26:29) = 'Peak' C xx xx xx.xx +xx xx xx.x xxxx.x xxx.x xxx.x TIT2 = ' h m s d m s mJy " " ' // C xx.x c xxxx.x -xx.x * ' deg mJy deg' END IF C Set epoch IF (EPOCOD.EQ.1) THEN TIT1(7:10) = '1900' TIT1(19:22) = '1900' ELSE IF (EPOCOD.EQ.2) THEN TIT1(7:10) = '1950' TIT1(19:22) = '1950' END IF C Blank fill title TIT1(NUMCOL+1:) = ' ' TIT2(NUMCOL+1:) = ' ' C Initial titles or if DIST scale C changes IF (FIRST .OR. (DISCL.NE.ODISCL)) THEN CALL PRTWRI (PRUNIT, TIT1, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 CALL PRTWRI (PRUNIT, TIT2, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 END IF ODISCL = DISCL C Passes DO 500 IPASS = 1,NPASS C Set range of rows. BC = MIN (MAX (BCI, BEG(IPASS)), NROW) IF (EC.LE.0) EC = NROW EC = MIN (ECI, END(IPASS)) IF (INC.LE.0) INC = 1 IF (NPASS.EQ.1) THEN C No RA wrap in search range RABEG = RAB RAEND = RAE ELSE IF (IPASS.EQ.1) THEN C Wrap - high hours RABEG = RAB RAEND = 360.0D0 ELSE C Wrap - low hours RABEG = 0.0D0 RAEND = RAE END IF C Find starting location if it's C sorted and indexed. IF (INDXED .AND. (SORT.EQ.1)) CALL FINDRA (RABEG, INDEX, * HDUNIT, VLKOLS, BC, IERR) IF (IERR.NE.0) THEN WRITE(0,2000) 'Error looking up source in FITS VL table' CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C Print selected rows. DO 100 IROW = BC,EC,INC C Read RA2000 NUM = 1 IEL = 1 IERR = 0 CALL FTGCVD (HDUNIT, VLKOLS(1), IROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) THEN WRITE(0,2000) 'Error reading RA from input FITS VL table' WRITE (0,2900) IERR 2900 FORMAT ('FTGCVD error number ',I5) CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C Want this one? IF (DOALL) THEN DIST2 = 0.0 ELSE C Quick test? IF ((RA2000.GE.RABEG) .AND. (RA2000.LE.RAEND)) THEN C Read DE2000 CALL FTGCVD (HDUNIT, VLKOLS(2), IROW, IEL, NUM, 0.0D0, * DE2000, ANYF, IERR) IF (IERR.NE.0) THEN WRITE(0,2000) * 'Error reading Dec from input FITS VL table' WRITE (0,2900) IERR CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C In RA range, use full test. RAR = RA2000 * DG2RAD DECR = DE2000 * DG2RAD CALL DIRCOS (2, RA0, DEC0, RAR, DECR, L, M, IERR) DIST2 = L*L + M*M ELSE IF((IPASS.EQ.NPASS) .AND. (RA2000.GT.RAEND)) THEN C Past RA Range, quit if sorted IF (SORT.EQ.1) GO TO 110 DIST2 = 1.0E10 ELSE C Before RA range. DIST2 = 1.0E10 END IF END IF WANTED = DIST2 .LE. RADR2 C Rectangular box? IF (.NOT.NOBOX) WANTED = WANTED .AND. * ((DE2000.GE.DECBEG) .AND. (DE2000.LE.DECEND)) IF (WANTED) THEN C Set output C Read full entry IR = IROW CALL VLTAB (HDUNIT, 'READ', IR, VLKOLS, FBLANK, * RA2000, DE2000, PEAK, MAJOR, MINOR, POSANG, QCENT, * UCENT,PFLUX, IRMS, PRMS, RESRMS, RESPEK, RESFLX, CENX, * CENY,FIELD, JDPRO, IERR) IF (IERR.LT.0) GO TO 100 IF (IERR.NE.0) THEN WRITE(0,2000) 'Error reading input FITS VL table' CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C Need to change epoch? IF ((EPOCOD.EQ.1) .OR. (EPOCOD.EQ.2)) THEN CALL CRDTRN (RA2000, DE2000, CRDPRM, RAT, DECT, ROTN) ELSE RAT = RA2000 DECT = DE2000 END IF CALL COORDD (1, RAT, DSIG, RAHM, RAS) CALL COORDD (2, DECT, DSIG, DECDM, DECS) IF (DECT.GT.0.0) DSIG = '+' C Distance from location DIST = SQRT (DIST2) DIST = MIN ((DISCL * (DIST / DG2RAD)), 999.9D0) C As character string IF (DIST.GE.10.0) THEN WRITE (CDIST,2001) DIST ELSE IF (DIST.GE.1.0) THEN WRITE (CDIST,2002) DIST ELSE WRITE (CDIST,2003) DIST END IF C Make corrections, get errors CALL CORERR (RAT, DECT, PEAK, MAJOR, MINOR, POSANG, * QCENT, UCENT, PFLUX, IRMS, PRMS, BEAM, FITTED, FBLANK, * FLUX, EFLUX, EPFLUX, CHPANG, CHEPAN, * ERRRA, ERRDEC, CMAJOR, CMINOR, CPA, EMAJOR, EMINOR, * EPA) C Percent polarization PCTPOL = 100.0 * PFLUX / FLUX C Convert units for output EFLUX = EFLUX * 1000.0 EPFLUX = EPFLUX * 1000.0 C Goodness of fit code IMARK = 1 TCUT = SQRT (CUTT*CUTT + (0.01*PEAK)**2) IF (RESRMS.GT.TCUT) IMARK = 2 IF (ABS(RESPEK).GT.TCUT) IMARK = 3 IF (RESFLX.GT.TCUT) IMARK = 4 C Check selection criteria SELECT = PEAK .GT. MINFLX SELECT = SELECT .AND. (PCTPOL.GT.MINPOL) IF (SELECT) THEN FOUND = .TRUE. C Create appropriate line IF (.NOT.DOALL) THEN C Default with pos select WRITE (LINE,1100) RAHM, RAS, DSIG, DECDM, * DECS, CDIST, FLUX*1000., CMAJOR, CMINOR, CPA, * MARK(IMARK), PFLUX*1000., CHPANG, FIELD, * CENX, CENY C Errors WRITE (ELINE,2100) ERRRA, ERRDEC, EFLUX, EMAJOR, * EMINOR, EPA, EPFLUX, CHEPAN ELSE C Default WRITE (LINE,1101) RAHM, RAS, DSIG, DECDM, * DECS, FLUX*1000., CMAJOR, CMINOR, CPA, * MARK(IMARK), PFLUX*1000., CHPANG, FIELD, CENX, * CENY C Errors WRITE (ELINE,2101) ERRRA, ERRDEC, EFLUX, EMAJOR, * EMINOR, EPA, EPFLUX, CHEPAN END IF C Count number printer SCOUNT = SCOUNT + 1 C Print line and errors LINE(NUMCOL+1:) = ' ' ELINE(NUMCOL+1:) = ' ' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (QUIT) GO TO 700 IF (IERR.NE.0) GO TO 990 CALL PRTWRI (PRUNIT, ELINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (QUIT) GO TO 700 IF (IERR.NE.0) GO TO 990 C Don't leave widows and orphans IF (PAGE.GE.LPAGE) PAGE = 1000 END IF END IF 100 CONTINUE 110 CONTINUE 500 CONTINUE C Close table 700 LAST = LAST .OR. QUIT CALL VLTAB (HDUNIT, 'CLOS', IR, VLKOLS, FBLANK, * RA2000, DE2000, PEAK, MAJOR, MINOR, POSANG, QCENT, UCENT, * PFLUX, IRMS, PRMS, RESRMS, RESPEK, RESFLX, CENX, CENY, * FIELD, JDPRO, IERR) IF (IERR.NE.0) GO TO 990 710 LAST = LAST .OR. QUIT IF (.NOT.FOUND) THEN LINE = 'SOURCE NOT FOUND' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 750 END IF C Close printer when done 750 LAST = LAST .OR. QUIT IF (LAST) THEN C Number found IF (SCOUNT.GT.0) WRITE(6,1700) SCOUNT IF (SCOUNT.LE.0) WRITE(0,2000) * 'NO SOURCES MEETING SELECTION CRITERIA FOUND' IF (PRNAME.NE.' ') THEN C Give user the happy news WRITE (6,2000) 'Output written to file:', PRNAME END IF CALL PRTCLO (PRUNIT, IERR) END IF IF (IERR.NE.0) GO TO 990 GO TO 999 C Error 985 CONTINUE 990 CONTINUE WRITE (0,2000) 'ERROR printing NRAO/VLA Survey catalog' C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('Selecting sources within ',F6.3,' degree of ', * I2, I3, F7.3, 1X, A, I2.2, I3, F6.2) 1002 FORMAT ('Selecting sources brighter than ',F7.3,' Jy') 1003 FORMAT ('Selecting sources more than ',F5.1,' % polarized') 1004 FORMAT ('Selection box: ',F5.2,' hr x' F6.2' deg with center ', * I2, I3, F7.3, 1X, A, I2.2, I3, F6.2) 1100 FORMAT (I2.2, I3.2, F6.2, 1X, A, I2.2, I3.2, F5.1, A, F7.1, A, * A, A, 1X, A, F7.2, A, 1X, A, 2F8.2) 1101 FORMAT (I2.2, I3.2, F6.2, 1X, A, I2.2, I3.2, F5.1, F7.1, A, A, A, * 1X, A, F7.2, A, 1X, A, 2F8.2) 1700 FORMAT ('Found ',I9,' entries') 2000 FORMAT (A) 2001 FORMAT (F6.1) 2002 FORMAT (F6.2) 2003 FORMAT (F6.3) 2100 FORMAT (2X, 3X, F6.2, 1X, 1X, 2X, 3X, F5.1, 6X, F7.1, A, A, A, * 3X, F7.2, A) 2101 FORMAT (2X, 3X, F6.2, 1X, 1X, 2X, 3X, F5.1, F7.1, A, A, A, * 3X, F7.2, A) 3000 FORMAT ('Using VL table ',I2, ' in FITS file:') END SUBROUTINE FINDRA (RA, INDEX, UNIT, VLKOLS, ROW, IERR) C----------------------------------------------------------------------- C Looks up the first row in an open VL table with the RA exceeding RA. C Inputs: C RA D Desired right ascension (J2000) degrees 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. (25) = number of rows C UNIT I Fortran I/O unit number C VLKOLS I(*) Array of column numbers for table entries C Outputs: C ROW I Row number on VL table C IERR I Error code, 0=> OK C----------------------------------------------------------------------- DOUBLE PRECISION RA INTEGER INDEX(*), UNIT, VLKOLS(*), ROW, IERR C DOUBLE PRECISION RA2000, RAHR, FRAC INTEGER IROW, IEL, NUM, IHOUR, INEXT, TSTROW, N LOGICAL ANYF C----------------------------------------------------------------------- IERR = 0 NUM = 1 IEL = 1 C First guess - interpolate RAHR = RA / 15.0D0 IHOUR = RAHR FRAC = RAHR - IHOUR INEXT = IHOUR + 1 TSTROW = INDEX(IHOUR+1) + FRAC * (INDEX(INEXT+1) - INDEX(IHOUR+1)) CALL FTGCVD (UNIT, VLKOLS(1), TSTROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) GO TO 999 C Steps of 50 C Go forward or backwards? IF (RA2000.LT.RA) THEN C Forward N = INDEX(INEXT+1) - TSTROW + 1 DO 100 IROW = 1,N TSTROW = TSTROW + 50 IF (TSTROW.GT.INDEX(25)) THEN TSTROW =INDEX(25) GO TO 250 END IF CALL FTGCVD (UNIT, VLKOLS(1), TSTROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) GO TO 999 C Past it? IF (RA2000.GT.RA) GO TO 250 100 CONTINUE ELSE C Backwards N = TSTROW - INDEX(IHOUR+1) + 1 DO 200 IROW = 1,N TSTROW = TSTROW - 50 IF (TSTROW.LT.1) THEN TSTROW = 1 GO TO 250 END IF CALL FTGCVD (UNIT, VLKOLS(1), TSTROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) GO TO 999 C Past it? IF (RA2000.LT.RA) GO TO 250 200 CONTINUE END IF C Steps of 1 C Go forward or backwards? 250 IF (RA2000.LT.RA) THEN C Forward N = INDEX(INEXT+1) - TSTROW + 1 DO 300 IROW = 1,N TSTROW = TSTROW + 1 IF (TSTROW.GT.INDEX(25)) GO TO 500 CALL FTGCVD (UNIT, VLKOLS(1), TSTROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) GO TO 999 C Found it? IF (RA2000.GT.RA) THEN ROW = TSTROW IERR = 0 GO TO 999 END IF 300 CONTINUE ELSE C Backwards N = TSTROW - INDEX(IHOUR+1) + 1 DO 400 IROW = 1,N TSTROW = TSTROW - 1 IF (TSTROW.LT.1) GO TO 500 CALL FTGCVD (UNIT, VLKOLS(1), TSTROW, IEL, NUM, 0.0D0, * RA2000, ANYF, IERR) IF (IERR.NE.0) GO TO 999 C Found it? IF (RA2000.LT.RA) THEN ROW = TSTROW + 1 IERR = 0 GO TO 999 END IF 400 CONTINUE END IF C If it gets here punt 500 ROW = INDEX(IHOUR+1) IERR = 0 999 RETURN END SUBROUTINE STCARD (LINE, RA, DEC, RADIUS, SLABEL, IERR) C----------------------------------------------------------------------- C Decodes one source position card. C Inputs: C LINE C*? Input card to be decoded C Output: C RA D RA (deg) C DEC D Dec (deg) C RADIUS D Search radius (deg) C SLABEL C*? Source label C IERR I Error code 0=> Ok C----------------------------------------------------------------------- CHARACTER LINE*(*), SLABEL*(*) INTEGER IERR DOUBLE PRECISION RA, DEC, RADIUS C CHARACTER M*1, TMPCHR*24 DOUBLE PRECISION DDX INTEGER IS, IDEC, IRA, ICOL, KBPTR, ITRIM, CTRIM, NONBLK, * MXSTLB, ICTYPE(8), LENLIN LOGICAL ISNUMB DATA ICTYPE /1, 1, 1, 2, 2, 2, 3, 4/ C----------------------------------------------------------------------- C Barf on blank card IF (LINE.EQ.' ') THEN IERR = 1 GO TO 999 END IF LENLIN = CTRIM (LINE) MXSTLB = LEN (SLABEL) KBPTR = 0 IERR = 0 C Set Defaults RA = 0.0D0 DEC = 0.0D0 RADIUS = 0.0D0 SLABEL = ' ' IRA = 0 IDEC = 0 IS = 1 C For all columns in table DO 140 ICOL = 1, 8 C Find next non-blank 115 KBPTR = KBPTR + 1 C End of line reached IF (KBPTR.GT.LENLIN) GO TO 990 C Find next non blank M = LINE(KBPTR:KBPTR) IF (M.EQ.' ') GO TO 115 C Declination leading sign IF (ICTYPE(ICOL).EQ.2) THEN C If a sign IF ((M.EQ.'-') .OR. (M.EQ.'+')) THEN IF (M.EQ.'-') IS = -1 GO TO 115 END IF END IF C IF char is number ISNUMB = M.EQ.'0'.OR.M.EQ.'1'.OR.M.EQ.'2'.OR.M.EQ.'3'.OR. * M.EQ.'4'.OR.M.EQ.'5'.OR.M.EQ.'6'.OR.M.EQ.'7'.OR. * M.EQ.'8'.OR.M.EQ.'9'.OR.M.EQ.'-'.OR.M.EQ.'+'.OR. * M.EQ.'.' C IF label column or not a number IF ((ICTYPE(ICOL).EQ.4) .OR. (.NOT. ISNUMB)) THEN C Transfer label chars TMPCHR = LINE(KBPTR:MIN(KBPTR+MXSTLB-1,LENLIN)) C Find number of non-blanks NONBLK = ITRIM(TMPCHR) SLABEL = TMPCHR(1:NONBLK) NONBLK = NONBLK + 1 KBPTR = LENLIN ELSE C Else get the number CALL GETNUM (LINE, LENLIN, KBPTR, DDX) C RA component? IF (ICTYPE(ICOL).EQ.1) THEN IRA = IRA + 1 IF (IRA.EQ.1) RA = DDX* 15.0D0 IF (IRA.EQ.2) RA = RA + DDX / 4.0D0 IF (IRA.EQ.3) RA = RA + DDX / 240.0 C Dec component ELSE IF (ICTYPE(ICOL).EQ.2) THEN DDX = ABS (DDX) IDEC = IDEC + 1 IF (IDEC.EQ.1) DEC = DDX IF (IDEC.EQ.2) DEC = DEC + DDX / 60.0 IF (IDEC.EQ.3) DEC = DEC + DDX / 3600.0 ELSE IF (ICTYPE(ICOL).EQ.3) THEN RADIUS = DDX END IF C End IF label column END IF C End of all columns loop 140 CONTINUE C Return values 990 IF (RA.LT.0.0) RA = RA + 360.0 DEC = DEC * IS C Default search = 15 seconds. IF (RADIUS.LE.0) RADIUS = 15.0D0 / 3600.0D0 C Should have checked at least 6 C columns. IF (ICOL.LE.6) IERR = 1 C 999 RETURN END INTEGER FUNCTION CTRIM (STRING) C----------------------------------------------------------------------- C Function to determine length of the nonblank portion of a string C ignoring possible comments. Comments are delimited with "!" C Use with calls like: C TRIMMED = GROSS(1:CTRIM(GROSS)) C NOTE: this does not check for NULL characters C----------------------------------------------------------------------- CHARACTER STRING*(*) C INTEGER ITRIM, IT, IC C----------------------------------------------------------------------- IC = INDEX (STRING, '!') IF (IC.LE.0) IC = LEN(STRING) IF (IC.GT.1) IC = IC - 1 IT = ITRIM (STRING(1:IC)) CTRIM = MIN (IT, IC) C 999 RETURN END