C----------------------------------------------------------------------- C; Copyright (C) 2002 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----------------------------------------------------------------------- PROGRAM VLIST C----------------------------------------------------------------------- C Program to display selected values from an 4MASS catalog as an C AIPS VL binary table extension to a FITS file. C----------------------------------------------------------------------- INTEGER IRET, JERR DOUBLE PRECISION RA, DEC, RAREQ, DECREQ, SEARCH, BOX(2), SILENT REAL MINFLX, MAXFLX, MINGLA, MAXGLA LOGICAL FIRST, LAST C INCLUDE 'FMSSLIST.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*80 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, DORAW C Parameter array REAL PARM(15) COMMON /FMSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED, DORAW COMMON /FMSSCH/ FTFILE, PRNAME, LABEL C INCLUDE 'TEXTCOM.INC' C Local include for text file C common. CHARACTER FILNAM*48, LINE*150 INTEGER TXUNIT LOGICAL INIT, ISOPEN COMMON /TFILCM/ INIT, ISOPEN, TXUNIT COMMON /CFILCM/ FILNAM, LINE C----------------------------------------------------------------------- C Startup CALL VLSUIN (IRET) C debug C WRITE (6,1000) IRET C 1000 FORMAT (' After VLSUIN IRET is ',I5) IF (IRET.NE.0) GO TO 990 FIRST = .TRUE. INIT = .TRUE. C Loop over positions 100 CALL NXTPOS (LAST, RA, DEC, RAREQ, DECREQ, SEARCH, BOX, SILENT, * MINFLX, MAXFLX, MINGLA, MAXGLA, IRET) IF (IRET.NE.0) GO TO 990 C Print selected portion of table CALL PRTVLT (FIRST, LAST, RA, DEC, RAREQ, DECREQ, SEARCH, BOX, * SILENT, MINFLX, MAXFLX, MINGLA, MAXGLA, 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 4MASSlist. C Input lines may include trailing comments delimited by "!" C Output: C IERR I Error code: 0 => ok C Output in common: C PRNAME C*? output file name C FILNAM C*? input file name C EPOCOD I Epoch/equinox code, 1=1900, 2=B1950, 3=J2000 C FITTED L If true show fitted values (not deconvolved) C DORAW L If true show really raw fitted values C PARM R(*) Control parameters C 1 = RA h C 2 = RA m C 3 = RA s C 4 = dec deg C 5 = dec min C 6 = dec sec C 7 = Search radius C 8 = Minimum I flux density C 10 = verification radius C 11 = search box half width in ra (hr) C 12 = search box half width in dec (deg) C 13 = Maximum I flux density C 14 = Minimum Galactic latitude C 15 = Maximum Galactic latitude C----------------------------------------------------------------------- INTEGER IERR C INTEGER I, I1, I2, MAXCAR, CTRIM, ITRIM, KBP, COUNT LOGICAL EXISTS REAL SEC CHARACTER SIGN*1, ILINE*132, HLPFIL*13, CFGDIR*68, FULFIL*80 DOUBLE PRECISION XVALUE C INCLUDE 'FMSSLIST.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*80 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, DORAW C Parameter array REAL PARM(15) COMMON /FMSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED, DORAW COMMON /FMSSCH/ FTFILE, PRNAME, LABEL C INCLUDE 'TEXTCOM.INC' C Local include for text file C common. CHARACTER FILNAM*48, LINE*150 INTEGER TXUNIT LOGICAL INIT, ISOPEN COMMON /TFILCM/ INIT, ISOPEN, TXUNIT COMMON /CFILCM/ FILNAM, LINE DATA HLPFIL /'4MASSlist.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 4MASS radio source list', * 'Version 0.0, 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 4MASSlist see', FULFIL ELSE WRITE (6,1000) 'Cannot find help file:', 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(1:CTRIM(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, 2=Raw 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. DORAW = .FALSE. ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) I1 = XVALUE + 0.5D0 FITTED = I1.GE.1 DORAW = I1.GE.2 END IF C Min,max flux density 140 WRITE(6,1000) 'Enter Minimum, maximum flux density (Jy)' // * ' [0 1.0E10]' 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 PARM(13) = 1.0E10 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(8) = XVALUE CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(13) = XVALUE IF (PARM(13).LT.0.001) PARM(13) = 1.0E10 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, verification radius in arcsec'// * '[15,0]' 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) = 15.0 PARM(10) = 0.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(7) = XVALUE IF (PARM(7).EQ.0.0) PARM(7) = 15.0 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(10) = 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 C Max., min., galactic lat. PARM(14) = 0.0 PARM(15) = 90.0 210 WRITE(6,1000) 'Max, min. abs gal. latitude in deg [0, 90]' C Allow to be missing READ(5,1000,ERR=900,END=999) ILINE IF (ILINE(1:1).EQ.'?') THEN CALL HELPME (12) GO TO 210 END IF IF (ILINE.EQ.' ') THEN PARM(14) = 0.0 PARM(15) = 90.0 ELSE MAXCAR = CTRIM(ILINE) KBP = 1 CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(14) = XVALUE CALL GETNUM (ILINE, MAXCAR, KBP, XVALUE) PARM(15) = XVALUE IF (PARM(15).LT.PARM(14)) PARM(15) = 90.0 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. Raw gives fitted values with no bias corrections.', * ' ' C Min,max flux density ELSE IF (CODE.EQ.5) THEN WRITE(6,1000) * 'Only sources with a peak brightness (Jy) greater than the', * 'first value and less than the second will be listed.', * 'If the second is absent it is assumed infinite. ', * 'If neither value is given then all flux densities are', * 'acceptable. ', * ' ' 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 arcsec. If a verification', * 'box (second value) is specified then a box of this half-', * 'width will be searched for other sources in the field.', * 'If nothing is found in the search radius, the distance to', * 'the closest source is given. This distinguishes between the', * 'case of no source at the given position and that region not', * 'yet in the catalog', * ' ' 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', * ' ' C Galactic latitude ELSE IF (CODE.EQ.12) THEN WRITE(6,1000) * 'This allows selection by abs galactic latitude in degrees.', * 'The first value is the minimum latitude, the second is', * 'the maximum desired. If the second is not given then', * 'all values higher than the first are given.', * 'If neither is given all values are acceptable.', * ' ' END IF C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE GETCFG (IERR) C----------------------------------------------------------------------- C GETCFG reads any values from configuration (4MASSlist.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 4MASSlist.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*13, CFGDIR*68, FULFIL*80 DOUBLE PRECISION XVALUE C INCLUDE 'FMSSLIST.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*80 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, DORAW C Parameter array REAL PARM(15) COMMON /FMSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED, DORAW COMMON /FMSSCH/ FTFILE, PRNAME, LABEL C INCLUDE 'TEXTCOM.INC' C Local include for text file C common. CHARACTER FILNAM*48, LINE*150 INTEGER TXUNIT LOGICAL INIT, ISOPEN COMMON /TFILCM/ INIT, ISOPEN, TXUNIT COMMON /CFILCM/ FILNAM, LINE DATA CFGFIL /'4MASSlist.cfg'/ C----------------------------------------------------------------------- IERR = 0 C Standard defaults FTFILE = './CATALOG.FIT' C debug C FTFILE = '/home/nraoweb/cv/etc/4mass/bin/linux/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, RAREQ, DECREQ, SEARCH, BOX, * SILENT, MINFLX, MAXFLX, MINGLA, MAXGLA, 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 RAREQ D RA center of search, deg, in epoch requested C DECREQ D Dec center of search, deg, in epoch requested C SEARCH D Search radius in arcsec, <= 0 => all selected. C BOX D(2) RA and Dec halfwidth of search rectangle C SILENT D Half width of silent search box. C MINFLX R Minimum peak flux density. C MAXFLX R Maximum peak flux density. C MINGLA R Minimum abs galactic latitude C MAXGLA R Minimum abs galactic latitude C IERR I Error code: 0 => ok C----------------------------------------------------------------------- LOGICAL LAST DOUBLE PRECISION RA, DEC, RAREQ, DECREQ, SEARCH, BOX(2), SILENT REAL MINFLX, MAXFLX, MINGLA, MAXGLA INTEGER IERR C CHARACTER CRDNAM(3)*40 DOUBLE PRECISION CRDPRM(11), ROTN, RAT, DECT C INCLUDE 'FMSSLIST.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*80 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, DORAW C Parameter array REAL PARM(15) COMMON /FMSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED, DORAW COMMON /FMSSCH/ FTFILE, PRNAME, LABEL C INCLUDE 'TEXTCOM.INC' C Local include for text file C common. CHARACTER FILNAM*48, LINE*150 INTEGER TXUNIT LOGICAL INIT, ISOPEN COMMON /TFILCM/ INIT, ISOPEN, TXUNIT COMMON /CFILCM/ FILNAM, LINE DATA CRDNAM /'EQUATORIAL b1900.0', 'EQUATORIAL b1950.0', * 'EQUATORIAL J2000.0'/ C----------------------------------------------------------------------- C Source selection from adverbs MINFLX = PARM(8) MAXFLX = PARM(13) BOX(1) = PARM(11) BOX(2) = PARM(12) MINGLA = PARM(14) MINGLA = MAX (0.0, MINGLA) MAXGLA = PARM(15) MAXGLA = MIN (90.0, MAXGLA) C debug C WRITE (6,1101) "Find next source" 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) SILENT = PARM(10) 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) C debug C WRITE (6,1101) LINE 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, SILENT, 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? C Save position in original. 500 RAREQ = RA DECREQ = DEC 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, RAREQ, DECREQ, SEARCH, * BOX, SILENT, MINFLX, MAXFLX, MINGLA, MAXGLA, 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 RAREQ D RA center of search, deg, in epoch requested C DECREQ D Dec center of search, deg, in epoch requested C SEARCH D Search radius in arcsec, <= 0 => all selected. C BOX D(2) RA and Dec halfwidth of search rectangle C SILENT D Half width of silent search box. C MINFLX R Minimum peak flux density. C MAXFLX R Maximum peak flux density. C MINGLA R Minimum abs galactic latitude C MAXGLA R Minimum abs galactic latitude C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- DOUBLE PRECISION RA, DEC, RAREQ, DECREQ, SEARCH, BOX(2), SILENT LOGICAL FIRST, LAST INTEGER IERR REAL MINFLX, MAXFLX, MINGLA, MAXGLA, 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, * ECOUNT, NCOUNT, NUMVL, ITEMP, ITRIM, IBADVL REAL RAS, DECS, BEAM(3), CUTT, TCUT, FLUX, PA, * EFLUX, EPFLUX, ERRRA, ERRDEC, PCTPOL LOGICAL WANTED, INDXED, DOALL, SELECT, QUIT, NORAD, NOBOX, ANYF, * FOUND, DOSIL, DOGAL CHARACTER LINE*132, ELINE*132, TIT1*132, TIT2*132, LLINE*256, * DSIG*1, MARK(4)*2 CHARACTER CMAJOR*6, CMINOR*6, CPA*6, EMAJOR*6, EMINOR*6, EPA*6, * CRDNAM(4)*40, CDIST*6, CPOSA*6, * CHBDVL*4,CFLUX*7, CEFLUX*7 DOUBLE PRECISION RAC, DECC, DECX, 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, MIND2, MINDM, SILDEG, GALPRM(11), GLAT, GLON 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, DATEVL*20 C INCLUDE 'FMSSLIST.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*80 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, DORAW C Parameter array REAL PARM(15) COMMON /FMSSNU/ PARM, VER, HDNUM, HDUNIT, WIDTH, NLINT, NLFILE, * EPOCOD, FITTED, DORAW COMMON /FMSSCH/ FTFILE, PRNAME, LABEL DOUBLE PRECISION DG2RAD C Degrees per radian PARAMETER (DG2RAD = 1.745329252E-2) DATA MARK /' ', 'R*', 'P*', 'S*'/ C Survey minimum residual DATA CUTT /1.0/ DATA CRDNAM /'EQUATORIAL b1900.0', 'EQUATORIAL b1950.0', * 'EQUATORIAL J2000.0', 'GALACTIC'/ C Blanking value DATA FBLANK /1.23456E20/ SAVE PAGE, PAGENO, PRUNIT, LPAGE, SCOUNT, ECOUNT, NCOUNT, TIT1, * TIT2 DATA DATEVL /'Unknown'/ C----------------------------------------------------------------------- C Setup/Open output FOUND = .FALSE. ELINE = 'ELINE not initialized ' 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 ECOUNT = 0 NCOUNT =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 = '4 Meter All Sky Survey (4MASS) Catalog search, ver 0.0' 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 Open input table CALL VLINI (FTFILE, VER, HDNUM, HDUNIT, NROW, VLKOLS, BEAM, * SORT, NUMIND, INDEX, DATEVL, IERR) IF (IERR.NE.0) THEN WRITE (LINE,5000) IERR, FTFILE CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) WRITE(0,2000) 'ERROR opening input FITS VL table ' // FTFILE CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C debug C LINE = 'After VLINI' C CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, C * QUIT, IERR) C end debug NUMVL = NROW 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 Galactic DOGAL = (MINGLA.GT.0.0) .OR. (MAXGLA.LT.90.0) CALL CRDSET (CRDNAM(3), CRDNAM(4), GALPRM, IERR) IF (IERR.NE.0) THEN WRITE (0,2000) 'ERROR initializing coordinate transform' GO TO 999 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 Silent search? DOSIL = SILENT.GT.0.0D0 SILENT = MAX (0.0D0, SILENT) MIND2 = 1.0E20 SILDEG = SILENT / 3600.0D0 C Position search box RAC = RA DECC = DEC RA0 = RAC * DG2RAD DEC0 = DECC * DG2RAD RAREQ = RAREQ * DG2RAD DECREQ = DECREQ * DG2RAD RADIUS = SEARCH / 3600.0D0 C Search window? DOALL = (RADIUS.LE.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) IF (.NOT.NOBOX) THEN C??? RADIUS = MAX (BOX(1), BOX(2)) RADR2 = 1.0E20 NORAD = .TRUE. END IF C RA box fullwidth in hours BOXRA = 2.0D0 * BOX(1) / 15.0D0 BOXDEC = 2.0D0 * BOX(2) C Radius scaling C IF (RADIUS.LE.0.3) THEN C DISCL = 3600.0D0 C DISYM = '"' C ELSE IF (RADIUS.LE.10.0) THEN C DISCL = 60.0D0 C DISYM = '''' C ELSE C DISCL = 1.0D0 C DISYM = 'o' C END IF C Always give distance in sec and C PA DISCL = 3600.0D0 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 - MAX (BOX(2), SILDEG) DECEND = DECC + MAX (BOX(2), SILDEG) DECX = MIN (89.0D0, DECC) RAB = RAC - MAX (RADIUS, BOX(1), SILDEG) * / COS (DECX * DG2RAD) IF (RAB.LT.0.0) RAB = RAB + 360.0 RAE = RAC + MAX (RADIUS, BOX(1), SILDEG) * / COS (DECX * 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(MIN(IRAE,23)+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*1000.0 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 Maximum flux density IF (MAXFLX.LT.1.0E5) THEN WRITE (LINE,1202) MAXFLX*1000.0 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 Galactic latitude range WRITE (LINE,1302) MINGLA, MAXGLA CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 C Table data and number of entries WRITE (LINE,1005) DATEVL(1:ITRIM(DATEVL)), NUMVL CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 700 C Indexing 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' IF (DORAW) * LINE = 'Displaying raw 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 (.NOT.NORAD) THEN WRITE (LLINE,1000) LABEL(1:ITRIM(LABEL)), RADIUS*3600.0, * RAHM, RAS, DSIG, DECDM, DECS LINE = LLINE 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 Check declination IF (DEC.LT.-40.0) THEN LINE = 'WARNING: The 4MASS southern limit is declination -40!' CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 710 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 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 xxxxx xxxx.x xxx.x xxx.x TIT1 = ' RA(2000) Dec(2000) Dist(") Flux Major Minor' // C xx.x c J0000+00 1234.5 1234.5 * ' PA Res Field X_pix Y_pix' IF (FITTED) TIT1(32:35) = 'Peak' C xx xx xx.xx +xx xx xx.x xxxxx xxxx.x xxx.x xxx.x TIT2 = ' h m s d m s Ori Jy " " ' // C xx.x c * ' deg' 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 J0000+00 1234.5 1234.5 * ' PA Res 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 Jy " " ' // C xx.x c * ' deg' END IF C Set epoch IF (EPOCOD.EQ.1) THEN TIT1(7:10) = '1900' TIT1(18:21) = '1900' ELSE IF (EPOCOD.EQ.2) THEN TIT1(7:10) = '1950' TIT1(18:21) = '1950' END IF C Blank fill title TIT1(NUMCOL+1:) = ' ' TIT2(NUMCOL+1:) = ' ' C Only give headers once IF (FIRST) 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' 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' CALL PRTCLO (PRUNIT, IER) GO TO 999 END IF C Check Declination IF ((DE2000.LT.DECBEG) .OR. (DE2000.GT.DECEND)) * GO TO 100 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 C Closest source in silent window MIND2 = MIN (MIND2, DIST2) 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 C Make corrections, get errors CALL CORERR (RAT, DECT, PEAK, MAJOR, MINOR, POSANG, * IRMS, BEAM, FITTED, DORAW, FBLANK, FLUX, EFLUX, * ERRRA, ERRDEC, CMAJOR, CMINOR, CPA, EMAJOR, EMINOR, * EPA) CALL COORDD (1, RAT, DSIG, RAHM, RAS) CALL COORDD (2, DECT, DSIG, DECDM, DECS) IF (DECT.GT.0.0) DSIG = '+' C Distance from location with C possible corrections. RAR = RAT * DG2RAD DECR = DECT * DG2RAD CALL DIRCOS (2, RAREQ, DECREQ, RAR, DECR, L, M, IERR) DIST2 = L*L + M*M DIST = SQRT (DIST2) DIST = MIN ((DISCL * (DIST / DG2RAD)), 99999.D0) C As character string IF (DIST.GE.100.0) THEN ITEMP = DIST + 0.5 WRITE (CDIST,1001) ITEMP ELSE IF (DIST.GE.10.0) THEN WRITE (CDIST,2001) DIST ELSE WRITE (CDIST,2002) DIST END IF C Position angle from center PA = 57.296 * ATAN2(L, M+1.0D-20) IF (PA.LT.0) THEN ITEMP = PA - 0.5 ELSE ITEMP = PA + 0.5 END IF C As character string WRITE (CPOSA,1001) ITEMP C Convert flux density to string CFLUX = ' ' CEFLUX = ' ' IF (FLUX.LT.9999.99) THEN WRITE (CFLUX,4000,ERR=567) FLUX ELSE IF (FLUX.LT.999999.99) THEN WRITE (CFLUX,4001,ERR=567) FLUX ELSE ITEMP = FLUX + 0.5 IF (ITEMP.GT.9999) ITEMP = 9999 WRITE (CFLUX,4002,ERR=567) ITEMP END IF C Convert flux density error IF (EFLUX.LT.9999.9) THEN WRITE (CEFLUX,4000,ERR=567) EFLUX ELSE IF (FLUX.LT.999999.) THEN WRITE (CEFLUX,4001,ERR=567) EFLUX ELSE ITEMP = EFLUX + 0.5 IF (ITEMP.GT.9999999) ITEMP = 9999 WRITE (CEFLUX,4002,ERR=567) ITEMP END IF 567 IF (PCTPOL.LT.0.0) PCTPOL = 0.0 C Goodness of fit code IMARK = 1 CHBDVL = ' ' TCUT = SQRT (CUTT*CUTT + (0.01*PEAK)**2) IF (RESRMS.GT.TCUT) THEN IMARK = 2 IBADVL = 10.0 * RESRMS + 0.5 IF (IBADVL.GT.9999) IBADVL = 9999 WRITE (CHBDVL,1111) IBADVL END IF IF (ABS(RESPEK).GT.TCUT) THEN IMARK = 3 IBADVL = 10.0 * RESPEK + 0.5 IF (IBADVL.GT.9999) IBADVL = 9999 WRITE (CHBDVL,1111) IBADVL END IF IF (RESFLX.GT.TCUT) THEN IMARK = 4 IBADVL = 10.0 * RESFLX + 0.5 IF (IBADVL.GT.9999) IBADVL = 9999 WRITE (CHBDVL,1111) IBADVL END IF C Check selection criteria SELECT = (PEAK .GE. MINFLX) .AND. (PEAK .LE. MAXFLX) C Filter out really bad fits C Peak should be at least 3 times C RMS residual SELECT = SELECT .AND. ((PEAK/RESRMS).GT.3.0) C Galactic latitude range IF (DOGAL) THEN CALL CRDTRN (RA2000, DE2000, GALPRM, GLON, GLAT, ROTN) GLAT = ABS (GLAT) SELECT = SELECT .AND. * ((GLAT.GE.MINGLA) .AND. (GLAT.LE.MAXGLA)) END IF 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, CFLUX, CMAJOR, CMINOR, CPA, * MARK(IMARK), FIELD, CENX, CENY C Errors WRITE (ELINE,2100) ERRRA, ERRDEC, CPOSA, * CEFLUX, EMAJOR, EMINOR, EPA, CHBDVL ELSE C Default WRITE (LINE,1101) RAHM, RAS, DSIG, DECDM, * DECS, CFLUX, CMAJOR, CMINOR, CPA, * MARK(IMARK), FIELD, CENX, CENY C Errors WRITE (ELINE,2101) ERRRA, ERRDEC, * CEFLUX, EMAJOR, EMINOR, EPA, CHBDVL 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 IF (.NOT.DORAW) 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 IF (QUIT) PAGE = 2 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 ' C Silent search window? IF (DOSIL) THEN C Min source distance in arcmin MINDM = 60.0D0 * SQRT (MIND2) / DG2RAD IF (MINDM.LT.100.0D0) THEN ECOUNT = ECOUNT + 1 WRITE (LINE(18:),1710) MINDM ELSE NCOUNT = NCOUNT + 1 LINE(18:) = '(Nothing close - not cataloged yet?)' END IF END IF 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) THEN WRITE(LINE,1700) SCOUNT ELSE LINE = 'NO SOURCES MEETING SELECTION CRITERIA FOUND' END IF IF (SCOUNT.LE.0) WRITE(0,2000) LINE CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, PAGENO, * QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 790 IF (ECOUNT.GT.0) THEN WRITE(LINE,1701) ECOUNT CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 790 END IF IF (NCOUNT.GT.0) THEN WRITE(LINE,1702) NCOUNT CALL PRTWRI (PRUNIT, LINE, TIT1, TIT2, LPAGE, PAGE, * PAGENO, QUIT, IERR) IF (IERR.NE.0) GO TO 990 IF (QUIT) GO TO 790 END IF 790 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 4MASS catalog' C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A,': Search within ',F8.1,' arcsec of ', * I2.2, I3.2, F7.3, 1X, A, I2.2, I3.2, F6.2) 1002 FORMAT ('Selecting sources brighter than ',F9.1,' Jy') 1202 FORMAT ('Selecting sources fainter than ',F9.1,' Jy') 1302 FORMAT ('Abs. galactic latitude range ',F5.1,' to ',F5.1) 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) 1005 FORMAT ('Catalog made on ',A,' (yyyy-mm-dd) with ',I7,' entries') 1100 FORMAT (I2.2, I3.2, F6.2, 1X, A, I2.2, I3.2, F5.1, A, A, A, * A, A, 1X, A, 1X, A, 2F8.2) 1101 FORMAT (I2.2, I3.2, F6.2, 1X, A, I2.2, I3.2, F5.1, A, A, A, A, * 1X, A, 1X, A, 2F8.2) 1700 FORMAT ('Found ',I9,' entries') 1701 FORMAT (I9,' fields had no source') 1702 FORMAT (I9,' fields apparently not covered by catalog') 1710 FORMAT ('(Closest source is ',F8.2,' arcmin away)') 2000 FORMAT (A) 1001 FORMAT (I6) 1111 FORMAT (I4) 2001 FORMAT (F6.1) 2002 FORMAT (F6.2) 2003 FORMAT (F6.3) 2100 FORMAT (2X, 3X, F6.2, 1X, 1X, 2X, 3X, F5.1, A, A, A, A, A, * A) 2101 FORMAT (2X, 3X, F6.2, 1X, 1X, 2X, 3X, F5.1, A, A, A, A, A) 3000 FORMAT ('Using VL table ',I2, ' in FITS file:') 4000 FORMAT (F7.2) 4001 FORMAT (F7.1) 4002 FORMAT (I7) 5000 FORMAT ('ERROR ',I4,' opening input FITS VL table ',A) 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, SILENT, 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 SILENT D Half width of silent search box. C SLABEL C*? Source label C IERR I Error code 0=> Ok C----------------------------------------------------------------------- CHARACTER LINE*(*), SLABEL*(*) INTEGER IERR DOUBLE PRECISION RA, DEC, RADIUS, SILENT C CHARACTER M*1, TMPCHR*50 DOUBLE PRECISION DDX INTEGER IS, IDEC, IRA, ICOL, KBPTR, ITRIM, CTRIM, NONBLK, * MXSTLB, ICTYPE(9), LENLIN LOGICAL ISNUMB DATA ICTYPE /1, 1, 1, 2, 2, 2, 3, 4, 5/ 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 = ' ' SILENT = 0.0D0 IRA = 0 IDEC = 0 IS = 1 C For all columns in table DO 140 ICOL = 1, 9 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.5) .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 ELSE IF (ICTYPE(ICOL).EQ.4) THEN SILENT = 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 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