LOCAL INCLUDE 'FINDFILE.INC' C Program global common C Input lines of text CHARACTER RALINE*80, DECLIN*80, EPOLIN*80, SIZLIN*80 C VLSS file name CHARACTER FMSSFL*60 C Position DOUBLE PRECISION RA, DEC COMMON /FINFNU/ RA, DEC COMMON /FINFCH/ RALINE, DECLIN, EPOLIN, SIZLIN, FMSSFL LOCAL END PROGRAM FNDFIL C----------------------------------------------------------------------- C Program to determine which VLSS field contains a given position and C return the contents of the file needed to pass to program postage. C The order of the input (stdin) is (free format, comments follow !): C hh mm ss.s ! Right Ascension of center (comments are allowed) C +/-dd mm ss.s ! Declination C 2000 ! Equinox, can be 1900, 1950, 2000 [anything else=2000(J)] C ra_width, dec_width ! width of image in degrees [0.50 0.50] C The output file (stdout) is C VLSS_image ! name of VLSS image for input C----------------------------------------------------------------------- INTEGER IRET INCLUDE 'FINDFILE.INC' C----------------------------------------------------------------------- C Startup, get input CALL FINFIN (IRET) IF (IRET.NE.0) GO TO 999 C Precess if necessary to J2000 CALL FINPRE (IRET) IF (IRET.NE.0) GO TO 999 C Determine VLSS file name CALL FINAME (IRET) IF (IRET.NE.0) GO TO 999 C Write output CALL FINOUT (IRET) C 999 STOP END SUBROUTINE FINFIN (IERR) C----------------------------------------------------------------------- C Read input for findfile C Input lines may include trailing comments delimited by "!" C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C INTEGER I1, I2, MAXCAR, CTRIM, KBP REAL SEC CHARACTER SIGN*1, ILINE*132 DOUBLE PRECISION XVALUE INCLUDE 'FINDFILE.INC' C----------------------------------------------------------------------- IERR = 0 ILINE = 'Nothing read yet' C Swallow input from stdin C RA line READ(5,1000,ERR=900,END=900) RALINE ILINE = RALINE C Declination line READ(5,1000,ERR=900,END=900) DECLIN ILINE = DECLIN C Epoch/equinox READ(5,1000,ERR=900,END=900) EPOLIN ILINE = EPOLIN C Field size READ(5,1000,ERR=900,END=900) SIZLIN ILINE = SIZLIN C decode RA MAXCAR = CTRIM(RALINE) ILINE = RALINE(1:MAXCAR) IF (ILINE.EQ.' ') THEN I1 = 0 I2 = 0 SEC = 0.0 ELSE 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 C Convert to degrees RA = (I1 + (I2 / 60.0D0) + (SEC/3600.0D0)) * 15.0D0 C Declination MAXCAR = CTRIM(DECLIN) ILINE = DECLIN(1:MAXCAR) 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 C Convert to degrees DEC = (I1 + (I2 / 60.0D0) + (SEC/3600.0D0)) IF (SIGN.EQ.'-') DEC = -DEC GO TO 999 C Error 900 WRITE (0,1000) '4Mfile:Error reading input ' WRITE (6,1000) 'ERROR' WRITE (6,1000) ILINE(1:CTRIM(ILINE)) IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE FINPRE (IERR) C----------------------------------------------------------------------- C Precess position if not in J2000 C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C INTEGER EPOCOD, LENCHK, CTRIM CHARACTER CRDNAM(3)*40 DOUBLE PRECISION CRDPRM(11), ROTN, RA2000, DE2000 INCLUDE 'FINDFILE.INC' DATA CRDNAM /'EQUATORIAL b1900.0', 'EQUATORIAL b1950.0', * 'EQUATORIAL J2000.0'/ C----------------------------------------------------------------------- IERR = 0 C Determine epoch EPOCOD = -1 LENCHK = CTRIM (EPOLIN) IF (INDEX (EPOLIN(1:LENCHK), '1900') .GT. 0) EPOCOD = 1 IF (INDEX (EPOLIN(1:LENCHK), '1950') .GT. 0) EPOCOD = 2 IF (INDEX (EPOLIN(1:LENCHK), '2000') .GT. 0) EPOCOD = 3 IF (EPOCOD.LE.0) EPOCOD = 3 IF (EPOCOD.EQ.3) GO TO 999 C Must precess C Get transformation constants CALL CRDSET (CRDNAM(EPOCOD), CRDNAM(3), CRDPRM, IERR) IF (IERR.NE.0) THEN WRITE (0,1000) 'ERROR initializing coordinate transform' GO TO 900 END IF C Precess CALL CRDTRN (RA, DEC, CRDPRM, RA2000, DE2000, ROTN) RA = RA2000 DEC = DE2000 GO TO 999 C Error 900 WRITE (0,1000) '4Mfile:Error precessing position ' WRITE (6,1000) 'ERROR' IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END SUBROUTINE FINAME (IERR) C----------------------------------------------------------------------- C Determine which VLSS field C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C DOUBLE PRECISION TOLDEC C Maximum distances to "belong". PARAMETER (TOLDEC = 5.0D0) DOUBLE PRECISION ADEC, DELTRA, RACELL, RACEN CHARACTER SIGN*1 INTEGER IRAH, IRAM, IDD, NUMMAP(9,2), I, IDEC, IRACEL, CTRIM INCLUDE 'FINDFILE.INC' C Number of maps per dec strip DATA NUMMAP /5, 15, 25, 35, 45, 55, 65, 75, 85, * 36, 36, 32, 30, 30, 24, 18, 12, 6/ C----------------------------------------------------------------------- IERR = 0 C Must be north of -36 dec. IF (DEC.LT.-36.0D0) THEN WRITE (0,1000) 'VLSS only goes to declination -36 deg.' IERR = 8 GO TO 900 END IF C Find declination strip, C Determine width in RA, C NUMMAP(*,1) = dec, center C NUMMAP(*,2) = number of maps IDEC = -1 ADEC = ABS (DEC) DO 100 I = 1,23 IF (ABS (ADEC-NUMMAP(I,1)) .LE. TOLDEC) THEN IDD = NUMMAP(I,1) IDEC = I GO TO 110 END IF 100 CONTINUE C Big trouble if you get here IERR = 9 GO TO 900 C Determine width in RA, 110 DELTRA = 360.0D0 / NUMMAP(IDEC,2) C Central RA RACELL = RA / DELTRA IRACEL = RACELL + 0.5 IF (IRACEL.GE.NUMMAP(IDEC,2)) IRACEL = 0 RACEN = IRACEL * DELTRA / 15.0D0 IRAH = RACEN + 0.05D0 IRAM = 60.0D0 * (RACEN - IRAH) + 0.1D0 C Sign of declination IF (DEC.GE.0.0D0) THEN SIGN = '+' ELSE SIGN = '-' END IF C Put it all together WRITE (FMSSFL,2000) IRAH, IRAM, SIGN, IDD GO TO 999 C Error 900 WRITE (0,1000) '4Mfile:Error determining VLSS field ' WRITE (6,1000) 'ERROR' WRITE (6,2000) IRAH, IRAM, SIGN, IDD IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) 2000 FORMAT (2I2.2,A1,I2.2,'0.FITS') END SUBROUTINE FINOUT (IERR) C----------------------------------------------------------------------- C Write output C Output: C IERR I Error code: 0 => ok C----------------------------------------------------------------------- INTEGER IERR C INTEGER ITRIM INCLUDE 'FINDFILE.INC' C----------------------------------------------------------------------- IERR = 0 C VLSS file name WRITE (6,1000,ERR=900) FMSSFL(1:ITRIM(FMSSFL)) * // ' ! VLSS file name' GO TO 999 C Error 900 WRITE (0,1000) '4Mfile: Error writing output ' WRITE (6,1000) 'ERROR' IERR = 5 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT (A) END