FTN77,S 
$FILES 2,2
      PROGRAM OBCAL (3,80)
*************************** 
* 
*          VERSION TO RUN UNDER SCHDL TO OBSERVE CALIBRATORS
*            SINGLE BEAM AT ALL FREQUENCIES 
* 
*     PROGRAM TO STEP AROUND ALL BEAMS IN DEC AND RA
* 
*       SOURCES READ FROM A SOURCE FILE.
* 
*          Added 40 mdeg to all RAOFS  on 1985/08/01  D213
*          New feed positions 1985/08/07.  Changed RAOFS DEOFS D 232
*         3.6 and 6 cm DEOFS changed 1986/08/29  d241 
*         3.6 cm new feeds and offsets D349/1986 15 12 86 
*         6 cm DEOFS changed from -.556 to -.552 2 7 87 d183 
*       
*         NB  New feed positions for 6 1nd 3.6 cm as from 21-05-88
*                                                         d 141 
*          NEW FEED OFFSETS 13S, 18S, 6D 3.6D AS OF 29 MAR 1990 
*          18S,6D & 3.6D UPDATED 1990 OCT 31
*          ALL UPDATED  10/7/91 
*          UPDATED TO READ FROM SYAPRM::16 USING STANDARD &RDSYS::16
*          5/4/94 BY JFHQ 
* 
*      TUFLUX AT 18CM CHANGED FROM 117 TO 403 ON D336/92
*      FUNT18  "   "     "      "  147 "   "  506  "
* 
*          Use of Fluke 8840 DVM 1985/10/24 
*          Writing ST to file hkeeping from D195/86  ie 14/7/86 
*        Change to meas of CE at end of 1st beam, instead of 2nd D205/86
* 
*        COPY OF TNSTP AT 1991/11/12  D316
*     some blank lines removed from printout to save paper MJG 1993 09 05 
*     added synthesizer setting code for spectral line usage JFHQ 1996 04 23
*     WRITTEN BY DCB 1982/04/30  UPDATED  <960423.1538> 
* 
********************************************************************* 
* 
      PARAMETER ( NFRQ=6 )
* 
      CHARACTER CPLACE(20)*2, NAMRFL*10, stathy*2 
* 
      LOGICAL AOK, START, CHK, HKEEP, PROB, NEXT, FIRE, 
     *        RPTFQ, CONSRA, DUALBM, WVTB, CALSRS, IFBRK, 
     *        NO3P4, BELOW
* 
      INTEGER ITIME(5), IPRAM(5), FILNAM(3), SWIN, DPRC2(3),
     *        FDCB(144), SORSBF(40), SORSNM(5), IANG(5),
     *        RESFIL(3), IDCB(272), IDUMY(2), ERSORS(10), IAB(2)
* 
      CHARACTER SYSTEM(NFRQ)*4
* 
      REAL    FNOFS(NFRQ), HPOFS(NFRQ), RAOFS(NFRQ),
     *        DEOFS(NFRQ), WAVE(NFRQ), TUFLUX(NFRQ),
     *        BMSEP(NFRQ), ERWAV(10), ERSQAV(10), MEDTB, MEDVM, 
     *        SFLUX(20), SERR(20), DVM(20), CALK(NFRQ)
* 
      COMMON  / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, 
     *                  HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                  I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV,
     *                  KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
       EQUIVALENCE (REG,IAB(1)),
     *             (RAP, IANG(1)),      (DECP, IANG(3)) 
* 
*        FNOFS is the angular offset of beam FIRST NULLS. 
*        HPOFS  "  "    "        "    "   "  HALF POWER points. 
*           FNOFS and HPOFS are measured from the beam peak.
*        RAOFS, DEOFS are the offsets of the FEEDS. 
*             Measured to beam peak (single beam) - now from SYPARM::16 
* 
*        BMSEP is the angular separation (peak to peak) of dual beams 
* 
*        TUFLUX is the NOISE TUBE equivalent flux in Jansky.
*          FUNT18 is the 18cm TUFLUX value for UNtilted subreflector. 
* 
*        ISIZE, ITYPE, ISECU, ICR refer to the RESULTS FILE.
*          Results are written on to RESFIL which has form BSday. 
* 
*        HALIM is the Hour Angle limit for acceptable data
* 
      DATA SYSTEM/  '  6S', '3.6S',  ' 13S',  ' 18S',  '2.5S', '4.5S'/, 
     *     WAVE  /  6.1,     3.4,     13.0,    18.0,    2.5,    4.5  /, 
     *     FNOFS /  0.18,    0.115,   0.393,   0.559,   0.071,  0.121/, 
     *     HPOFS /  0.082,   0.048,   0.166,   0.232,   0.035,  0.062/, 
C---------------------- Now picked up from SYPARM::16 ------------------- 
     *     RAOFS /  0.569,   0.015,   0.071,   0.096,  -0.395, -0.458/, 
     *     DEOFS / -0.214,  -0.603,   0.413,   0.904,   0.220, -0.112/, 
C------------------------------------------------------------------------ 
     *     BMSEP /    0.0,     0.0,    0.0,      0.0,     0.0,   0.0 /, 
     *     TUFLUX/  200.0,   175.0,    40.2,   403.0,   4440.,  1200./, 
     *     FUNT18/                             506.0                 /, 
     *     ISIZE / 5 /,  ITYPE /  3 /, ISECU / 0 /, ICR / 15 /, 
     *     RESFIL / 2HBS, 2H00, 2H   /, 
     *     HALIM  / 5.4 /,
     *     CHK / .FALSE. /, LU / 7 /, 
     *     DPRC2 / 2HDP, 2HRC, 2H2  /,
     *     filnam / 6HSHCALS /, nfirst / 1 /
* 
            call rmpar(ipram) 
* 
*        Initialise resources 
* 
           CALL FSYSU (LU, LU)
           PRINT '(A1)', CHAR(14B)   ! Form feed
* 
*        Set to zero the counter of the number of completed tracks. 
*          KERR counts if largest no. out of DVM exceeds limit s.t. 
*               program gives only 5 significant figures (2exp23-1)*10
           NUMTRK = 0 
           NSETS = 0
           KERR = 0 
           RPTFQ = .FALSE.
           IDCBS  = 256 
* 
*   If bit 15 has been set by previous program, reset it. 
* 
           If (issw(15) .lt. 0) then
               iswit = swin(0)
               iswit = iswit .and. 077777B
               call swout(iswit)
           endif
* 
*   Ensure all Noise Diodes are off so calibration works
* 
      CALL EXEC (2, 113B, 0, 1, 3, 3) 
* 
*   Print suitable Program Header 
* 
      CALL EXEC(11,ITIME,IYEAR) 
      WRITE (LU,1000) ITIME(5),IYEAR
 1000 FORMAT(  3X,"ON/OFF TRACKING PROGRAM (OBCAL) : DAY ",I3,",",I4
     *        /3X,38"=")
C    *        /3X,"THIS VERSION STEPS AROUND single ALL BEAMS", 
C    *        /3X," Source file must use 1950.0 coordinates. ", 
C    *        /3X," Set S register bit 0 ON to suspend 3.4 cm readings" 
C    *        /22X," 1 ON to suspend 6.1 cm readings,"
C    *        /22X," 2 ON to suspend 13.0cm readings" 
C    *        /22X," 3 ON to suspend 18.0cm readings" 
C    *        /22X," 4 ON to suspend 2.5 cm readings,"
C    *        /22X," 5 ON to suspend 4.5 cm readings,"
C    *        /22X," 9 ON to repeat current FREQ."
C    *        /22X," 10 ON to repeat current SOURCE " 
C    *        /22X," 13 ON to SUSPEND the program"
C    *        /22X," 14 ON to SKIP the next source "
C    *        /22X," 15 ON to END PROGRAM."  )
* 
*             Read the hyperbola focus and tilt to decide which offsets 
*             to use for the 18 cm feeds. 
* 
             call rhyp (focus, tilt)
* 
             If (tilt .gt. 0.0) then
                stathy = '  ' 
             else 
                stathy = 'UN' 
                SYSTEM(4) = ' 18U'  
                TUFLUX(4) = FUNT18
             endif
* 
               print '("Hyperbola focus ", F6.2," cm. Tilt ", F6.2, 
     *                  " V.",/,
     *                  " i.e. hyperbola is ",A2,"TILTED.")', 
     *                  focus, tilt, stathy 
* 
*        Pick up beam offsets from SYPARM::16 using standard &RDSYS::16 
* 
           do 111 ibo = 1,NFRQ
             call RDSYS (ibo, SYSTEM, RAOFS, DEOFS, CALK) 
  111      continue 
* 
*        Obtain the UNIVERSAL TIMES of Sunrise and Sunset and convert 
*          to decimal.
* 
          CALL SUNTM (ITIME(5), IHSET, MSET, IHRIS, MRIS, 
     *                RASUN, DECSUN, *900,k)
              SUNSET = FLOAT(IHSET) + (FLOAT(MSET)/60.) 
              SUNRIS = FLOAT(IHRIS) + (FLOAT(MRIS)/60.) 
* 
           WRITE (LU,1250) SUNSET, SUNRIS 
 1250      FORMAT(" UT of sunset and sunrise in DECIMAL hrs : ",2F6.2)
* 
*          Subtract half hour from sunrise time so that END of measure
*             is before sunrise.
           SUNRIS = SUNRIS - 0.2
* 
*           Convert to seconds. 
              SUNRIS = SUNRIS * 3600. 
              SUNSET = SUNSET * 3600. 
* 
      WRITE (LU,3150)  (FILNAM(J), J=1,3), ipram(1) 
 3150   FORMAT( 3X," Using source file ",3A2, 
     *          1X," 1950.0 coordinates ",
     *          1X," Starting at source ",I4) 
* 
*    OPEN SOURCE FILE. If not found negative error IERR is returned.
* 
      CALL OPEN (FDCB,IERR,FILNAM)
       IF (IERR .GT. 0)   GO TO 350 
       WRITE (LU,3200)  IERR
 3200  FORMAT(" FILE NOT FOUND, FMP ERROR ",I6) 
      GO TO 900 
* 
*          File opened successfully. Close again temporarily. 
  350  CALL CLOSE (FDCB,IERR) 
        START = .TRUE.
* 
*     Derive name of results file, RESFIL.
* 
            IF ( ITIME(5) .GE. 100 )  GO TO 380 
            IF ( ITIME(5) .GE. 10 )   GO TO 370 
* 
              CALL CODE 
                 WRITE (IDUMY,3300)  RESFIL(2), ITIME(5)
 3300            FORMAT( A2, I1)
              GO TO 390 
* 
  370           CALL CODE 
                  WRITE (IDUMY,3400) RESFIL(2), ITIME(5)
 3400             FORMAT( A1, I2) 
                GO TO 390 
* 
  380              CALL CODE
                     WRITE (IDUMY,3500) ITIME(5)
 3500                FORMAT( I3)
* 
  390       CALL CODE 
              WRITE (RESFIL, 3600) RESFIL(1), (IDUMY(J), J=1,2) 
 3600         FORMAT(2A2,A1)
* 
        WRITE (NAMRFL, '(3A2,A2,A2)') (RESFIL(L),L=1,3),'::', ICR 
* 
*    Open file, if it exists. 
  810   CALL OPEN (IDCB, IERR, RESFIL, IDCBS) 
* 
*       Otherwise create file.
             IF (IERR .EQ. -006)   GO TO 820
             IF (IERR .GE. 0)    GO TO 825
* 
*        Close and write error. 
  815           CALL CLOSE (IDCB) 
                  WRITE (LU,8400) IERR, (resfil(l), l=1,3)
 8400             FORMAT(/" FMGR ERROR ",I4," in opening ", 3A2)
                    GO TO 900 
* 
*     Create file.
  820    CALL CREAT (IDCB, IERR, RESFIL, ISIZE, ITYPE, ISECU, ICR,IDCBS)
             IF (IERR .LT. 0)   GO TO 815 
* 
  825    CALL CLOSE (IDCB)
              WRITE (LU,8500)  (RESFIL(L), L=1,3) 
 8500         FORMAT( 3X," Results are in disc file ",3A2)
* 
*     Read the parameters of 1 source. Close the file after reading.
* 
*  START OF LOOP FOR EACH SOURCE. 
* 
  500   CONTINUE
* 
*                Check if BIT 15 has been set 
* 
           IF(ISSW(15) .LT. 0)     GO TO 900
* 
       NREC = ipram(1)
* 
*              Bit 14 set for skip to next source.
  512      IF (ISSW(14) .GE. 0)  GO TO 515
* 
*              Reset bit 14 
             ISWIT = SWIN(0)
             ISWIT = ISWIT .AND. 137777B
             CALL SWOUT(ISWIT)
             GO TO 500
* 
  515 CALL OPEN (FDCB,IERR,FILNAM)
      IF(IERR .GE. 0)     GO TO 520 
          WRITE (LU,3200) IERR
          GO TO 900 
* 
*     Position pointer in file -then read line of ASCII data
* 
  520   CALL POSNT(FDCB,IERR,NREC,1)
        CALL READF(FDCB,IERR,SORSBF,40,LEN) 
* 
       IF (IERR .GE. 0)   GO TO 530 
            WRITE (LU,5110) IERR, NREC
 5110      FORMAT (" FILE ERROR ",I6," AT LINE ",I6," PROGRAM ENDS ") 
            GO TO 900 
* 
  530  IF( START .AND. LEN .LE. 0)  GO TO 532 
* 
         GO TO 535
  532      WRITE (LU,5120)
 5120      FORMAT (" SOURCE NUMBER NOT FOUND ") 
           nrec = 1 
           go to 512
* 
  535  IF( LEN .GT. 0)  GO TO 540 
* 
             WRITE (LU,5130)
 5130         FORMAT (" END OF SOURCE FILE. RETURN TO No. 1"//) 
* 
           NREC = 1 
         GO TO 512
* 
*      Convert the ASCII data off the source file to BINARY 
* 
  540 CALL CODE 
      READ (SORSBF,5200)  NSORS, SORSNM, RH, RM, RS,
     *                    DD, DM, DS, CALSRS, NO3P4 
 5200 FORMAT(I3, 5A2, F2.0, F3.0, F5.1, F4.0, 2F3.0, L2, L1)
* 
*         Close file after source has been found
  560    CALL CLOSE (FDCB,IERR) 
         START = .FALSE.
* 
*    Calculate source coordinates RA0,DEC0 (ie. 1950) in decimal degrees
* 
      RA0 = (( RH*60.0 + RM ) * 60.0 + RS)/240.0
           IF( DD .NE. 0.0 )    GO TO 580 
            DD = 0.00001
            IF (( SORSBF(13) .AND. 77400B) .EQ. 26400B)  DD = -DD 
  580  DM = SIGN(DM,DD) 
       DS = SIGN(DS,DD) 
      DEC0 = DD + DM/60.0 + DS/3600.0 
         IF ( DEC0 .GT. 270.0)      DEC0 = DEC0 - 360.0 
* 
*        Precess coords to current time 
* 
            RAP = RA0 
            DECP = DEC0 
            CALL EXEC (9,DPRC2,IANG(1),IANG(2),IANG(3),IANG(4),IANG(5)) 
              CALL RMPAR (IANG) 
* 
*          Check offset of source from sun
* 
            CALL CLOSN (RAP, DECP, RASUN, DECSUN, NSORS, *512,ksun) 
* 
*     Obtain and print SIDERIAL TIME. 
* 
         STNOW = TIME(2)
           ISTH = STNOW / 3600.0
           ISTM = (STNOW - FLOAT(ISTH) * 3600.0) / 60.0 
           ISTS = STNOW - FLOAT(ISTH) * 3600.0 - FLOAT(ISTM) * 60.0 
* 
         WRITE (LU,5900) ISTH, ISTM, ISTS 
 5900    FORMAT(  3X,'Siderial time: ',I3,'H',I3,'M',I3,'S')
* 
*          Check the source HA. Skip or wait as necessary.
* 
                 RAHRS = RAP / 15.
                 SIDHRS = STNOW / 3600. 
             HA = SIDHRS - RAHRS
                      IF ( HA .GT. 12. )  HA = HA - 24. 
                      IF ( HA .LT. -12.)  HA = HA + 24. 
* 
*              Compare with limiting value
* 
                             HA = HA * 15.     ! Subroutine uses degrees
                 CALL LIMIT (HA, DECP, BELOW) 
                             HA = HA / 15.
* 
                 If ( BELOW )  then 
* 
                        WRITE (LU,5950)  NSORS, HA
 5950                   FORMAT(/,"Source",I4," HA",F6.2,"below horizon",
     *                         "GO TO NEXT SOURCE") 
* 
                      nrec = nrec + 1 
                    go to 512 
                  endif 
* 
*   Print source file information and headers for each track. 
* 
  600 WRITE (LU,6000) 
 6000 FORMAT(/1X," NO.  SOURCE     RA         DEC  Cal? 3.4? ") 
        WRITE (LU,6100) 
 6100   FORMAT(1X,"_")
          CALL EXEC (2,LU,SORSBF,LEN) 
* 
*         Print HEADERS for each track
* 
       WRITE (LU,6200)
 6200  FORMAT( /8X,"  FREQ     PLACE        START TRACK AT",12X,"FLUX"/ 
     *          8X," USED(cm) TRACKED   RA",7X,"DEC",6X,"TIME",8X,"(Jy)"
     *         /8X,8"=",2X,7"=",1X,7"=",2X,7"=",2X,8"=",4X,7"=")
* 
*      Write housekeeping on results file.
* 
         HKEEP = .TRUE. 
       CALL WINFO (LU, NFRQ, RESFIL, WVTB, WAVE,  
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, *900,k)
         HKEEP = .FALSE.
         IF ( PROB )    GO TO 900 
       GO TO 698
* 
*        Start point for repeat of source.
*               Reset bit 10 ie cancel source repeat. 
  690      ISWIT = SWIN(0)
           ISWIT = ISWIT .AND. 175777B
           CALL SWOUT(ISWIT)
* 
*  START OF LOOP FOR EACH FREQUENCY.
* 
  698  NSETS = NSETS + 1
* 
      DO 700   I=1,NFRQ 
* 
*        Bits 0, 1, 2, 3, 4, 5  set for skip, respectively, 
*            3.4, 6.1, 13.0, 18.0, 2.5, 4.5 cm. measurements
* 
               ISWIT = SWIN(0)
               ISWIT = ISWIT .AND. 000077B
                  GO TO (702, 701, 703, 704, 705, 706) I  
* 
  701              ISWIT = ISWIT .AND. 1B 
                   IF ( ISWIT .EQ. 1B )  GO TO 700
                       GO TO 711
  702                ISWIT = ISWIT .AND. 3B 
                     IF ( ISWIT .GE. 2B )  GO TO 700
                       GO TO 711
  703                ISWIT = ISWIT .AND. 7B 
                     IF ( ISWIT .GE. 4B )  GO TO 700
                       GO TO 711
  704                ISWIT = ISWIT .AND. 17B
                     IF ( ISWIT .GE. 10B)  GO TO 700
                       GO TO 711
  705                ISWIT = ISWIT .AND. 37B
                     IF ( ISWIT .GE. 20B)  GO TO 700
                         GO TO 711
  706                ISWIT = ISWIT .AND. 77B
                     IF ( ISWIT .GE. 40B)  GO TO 700
* 
  711       CONTINUE
* 
          PRINT '("Beam offsets at ", F4.1," cm. RA and Dec resp.", 
     *            2F8.3)', wave(i), raofs(i), deofs(i)
* 
*       Set up appropriate syntheisizer frequency 
* 
          call DOSYNTH(SYSTEM(I),IPRAM(2))
* 
*       Calculate antenna coords for each track and then track source.
* 
* 
*          Correct for BEAM OFFSETS 
           ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293)
           ONDEC= DECP + DEOFS(I) 
* 
*    Correction factor to RA due to DECLINATION 
          CORDEC = COS(ONDEC * 0.017453293) 
          SEPFAC = (BMSEP(I)/2.)/CORDEC 
* 
         GO TO 715
* 
*   Start point for repeat of particular freq.
*           Reset bit 9 ie. cancel freq repeat. 
* 
  710    ISWIT = SWIN(0)
         ISWIT = ISWIT .AND. 176777B
         CALL SWOUT (ISWIT) 
* 
  715    CONTINUE 
* 
             SEPFAC = -1. * SEPFAC
* 
*         TRACKING AT FIRST NULL. 
*          Calculate coordinates: 
* 
        TRA = ONRA - SEPFAC 
        TDEC= ONDEC + FNOFS(I)
        KPLACE = 2HFN 
* 
        FIRE = .TRUE. 
        CONSRA = .FALSE.
        WVTB = .TRUE. 
* 
*       Print source information. 
*        Track the source, print time antenna settles and track 
*           for required length of time- set in DATA statement. 
* 
       CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, 
     *             LU, NFRQ, TUFLUX, RESFIL, CONSRA,  
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
*      CONSRA is set TRUE when the RA is constant for consecutive tracks
              CONSRA = .TRUE. 
* 
*     TRACKING AT HALF POWER POINTS.
*           Calculate coodinates
* 
       TRA = ONRA - SEPFAC
       TDEC= ONDEC + HPOFS(I) 
       KPLACE = 2HHP
* 
        CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *              LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )   GO TO 700
         IF ( PROB )   GO TO 900
* 
*     TRACK ON SOURCE ie. at antenna beam peak. 
* 
         TRA = ONRA - SEPFAC
         TDEC = ONDEC 
         KPLACE = 2HON
* 
         CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, 
     *               LU, NFRQ, TUFLUX, RESFIL, CONSRA,    
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
*     TRACK AT HALF POWER 
* 
* 
         TRA = ONRA - SEPFAC
         TDEC= ONDEC - HPOFS(I) 
         KPLACE = 2HHP
* 
        CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *              LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
* 
*       TRACK AT FIRST NULL.
* 
          TRA = ONRA - SEPFAC 
          TDEC= ONDEC - FNOFS(I)
          KPLACE = 2HFN 
* 
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
*       Track at HP and FN pts offset in RA 
* 
                 TRA = ONRA - SEPFAC - FNOFS(I)/CORDEC  
                 TDEC = ONDEC 
                 KPLACE = 2HFN
                 CONSRA = .FALSE. 
* 
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
             TRA = ONRA - SEPFAC - HPOFS(I)/CORDEC  
             TDEC = ONDEC 
             KPLACE = 2HHP
             CONSRA = .FALSE. 
* 
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
*     TRACK ON SOURCE ie. at antenna beam peak. 
* 
         TRA = ONRA - SEPFAC
         TDEC = ONDEC 
         KPLACE = 2HON
* 
         CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, 
     *               LU, NFRQ, TUFLUX, RESFIL, CONSRA,    
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB ) GO TO 900
* 
            TRA = ONRA - SEPFAC + HPOFS(I)/CORDEC 
            TDEC = ONDEC
            KPLACE = 2HHP 
* 
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, CONSRA,   
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
                      TRA = ONRA - SEPFAC + FNOFS(I)/CORDEC 
                      TDEC = ONDEC
                      KPLACE = 2HFN 
  
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, CONSRA, 
     *             NAMRFL, SFLUX, SERR, DVM, CPLACE, NL)
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
*    Write fluxes etc from each position to file RESFIL 
* 
       CALL WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM,  
     *             NL, HKEEP, WVTB, RPTFQ, *900,k)
* 
*    Write out used value of noise tube in DVM units
         PRINT '("Noise tube ",F12.4," DVM units.", 
     *           " Assuming tube equivalent flux ",F8.2," Jy")',
     *    TUBNET, tuflux(i) 
* 
*    Bit 13 set for repeat of current frequency.
* 
               RPTFQ = .FALSE.
         IF ( ISSW(9) .GE. 0)   GO TO 700 
               RPTFQ = .TRUE. 
             GO TO 710
* 
  700 CONTINUE
* 
*       Bit 14 set for repeat of current source.
* 
         IF ( ISSW(10) .LT. 0)   GO TO 690
* 
  900 CONTINUE
* 
           IF (KERR .EQ. 0)  GO TO 910
* 
C            WRITE (LU,9960)
C9960        FORMAT(/," Limit for 6 sig fig accuracy exceeded at:"/ 
C    *                "    Source no.    Wave.     Value. ")
C              DO 905  KKK = 1,KERR 
C 
C                    IF ( KKK .LE. 10 )  GO TO 904
C                       WRITE (LU,9965) KERR
C9965                   FORMAT(" Limit exceeded >10 times ...", I3, 
C    *                         " times, in fact. ") 
C                    GO TO 906
C 904             WRITE (LU,9970) ERSORS(KKK), ERWAV(KKK),
C    *                            ERSQAV(KKK) 
C9970             FORMAT(6X, I4, 8X, F6.1, 5X, G12.6) 
C 905          CONTINUE 
* 
  906              CONTINUE 
C                  WRITE (LU,9975)
C9975              FORMAT(" If Source no. is >1000, error occurred" 
C    *                    " in reading TUBE."/
C    *                    "        Subtract 1000 to get source no.")
* 
  910          CONTINUE 
C              WRITE (LU,9980) NUMTRK 
C9980          FORMAT(" Number of tracks performed:", I4) 
C        WRITE (LU,9990) NSETS
C9990    FORMAT(" Total number of sets of readings obtained:",I4) 
* 
      WRITE (LU,9999) 
 9999 FORMAT("  *** END *** ")
 1080 FORMAT(L6)
      END 
* 
* 
********************************************************************* 
* 
*        SOURCE TRACKING SUBROUTINE 
*              Directly from MJG's VLBI2. See that program for details. 
* 
********************************************************************* 
* 
$ALIAS/POINT/,NOALLOCATE
      SUBROUTINE TRACK (LU,INTYPE,DLONG,DLAT, CONSRA) 
* 
      LOGICAL  LNGSCN, LATSCN, HASTOP, DECSTP, CONSRA 
      INTEGER  MES(12), CMDCLS, TSETL 
      COMMON  /POINT/ LOGCLS, CMDCLS
      EQUIVALENCE   (MES(1),ALONG),   (MES(3),ALAT),
     *              (MES(5),ITYPE),   (MES(6),CMDTIM),
     *              (MES(8),LNGSCN),  (MES(9),LATSCN),
     *              (MES(10),HASTOP), (MES(11),DECSTP), 
     *              (MES(12),NWAKE) 
* 
      DATA    LNGSCN, LATSCN, HASTOP /3* .FALSE. /, 
     *        DECSTP / .TRUE. / 
* 
      NCMD = CMDCLS 
      ITYPE = INTYPE
      ALONG = DLONG 
      ALAT = DLAT 
* 
* Negative track time: Tracks for up to 1 hour, INTERRUPTIBLE.
      CMDTIM = -1.0 
* 
*   Allocate and lock RESOURCE NUMBER NWAKE globally. 
         CALL RNRQ (12B,NWAKE,ISTAT)
* 
*   Pass message to COMND to go to position and track 
           CALL EXEC (20,0,MES,12,0,0,NCMD) 
* 
*    Lock, clear NWAKE to suspend here until on position
*    When woken by COMND
           CALL RNRQ (5B,NWAKE,ISTAT) 
* 
*        Deallocate NWAKE 
           CALL RNRQ (40B,NWAKE,ISTAT)
* 
*      Suspend for 52s while antenna settles, if RA changed:
*         otherwise wait for 12s. 
* 
           TSETL = 52 
        IF ( CONSRA )  TSETL = 12 
  200 CALL EXEC (12,0,2,0,-TSETL) 
        RETURN
      END 
* 
********************************************************************* 
* 
*       SUBROUTINE TO TRACK SOURCE, PRINT SOURCE INFO,SETTLING TIME AND 
*         STAY ON SOURCE FOR REQUIRED TIME. 
*                 Uses subroutines TRACK, FLUX, WINFO 
* 
**********************************************************************
* 
      SUBROUTINE DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,  
     *                  LU, NFRQ, TUFLUX, RESFIL, CONSRA, 
     *                  NAMRFL, SFLUX, SERR, DVM, CPLACE, NL) 
* 
         CHARACTER CPLACE(20)*2, NAMRFL*10
* 
         LOGICAL NEXT, PROB, HKEEP, FIRE, RPTFQ, CONSRA, WVTB, CALSRS 
* 
         INTEGER TIMON(5), RESFIL(3), ITIME(5), SORSNM(5),
     *           IDCB(272), ERSORS(10)
* 
         REAL  WAVE(1), TUFLUX(1), ERWAV(10), ERSQAV(10), MEDTB, MEDVM, 
     *         SFLUX(20), SERR(20), DVM(20) 
* 
        COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE,
     *                    HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                    I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV,
     *                    KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
           NUMTRK = NUMTRK + 1
* 
       WRITE (LU,1000) WAVE(I), KPLACE, TRA, TDEC 
 1000  FORMAT(9X, F5.1, 6X, 1A2, 4X, F7.3, 2X, F7.3,"_")
* 
         CALL TRACK (LU, 4, TRA, TDEC, CONSRA)
          CALL EXEC (11,TIMON)
             WRITE (LU,1100) TIMON(4), TIMON(3), TIMON(2) 
 1100        FORMAT(I4, 2I3," _") 
* 
*       Turn on DVM's, fire noise tube and compute source FLUX and
*           RMS ERROR.
* 
        CALL FLUX (LU, TUFLUX, WAVE)
            IF ( NEXT )   GO TO 911 
* 
*        Write source info onto disc file RESFIL. 
* 
           CALL WINFO (LU, NFRQ, RESFIL, WVTB, WAVE,  
     *                NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, *911,k) 
* 
  911  RETURN 
      END 
* 
********************************************************************* 
* 
*       SUBROUTINE TO WRITE DATA TO RESULTS FILE
* 
********************************************************************* 
* 
       SUBROUTINE WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM,  
     *                   NL, HKEEP, WVTB, RPTFQ, k,*) 
* 
      CHARACTER NAMRFL*10, SEGNAM*5, CPLACE(20)*2, FCHAR*42 
* 
      LOGICAL   HKEEP, WVTB, RPTFQ
* 
      REAL      SFLUX(20), SERR(20), DVM(20)
* 
*       File operations 
* 
*    Open file,if it exists 
* 
       Assign 110 to label
         NSTMT=110
         SEGNAM = 'WRTFL' 
  110  OPEN (50, file=NAMRFL, iostat=ierr, err=820, status='OLD') 
* 
*         Find EOF
       Assign 120 to label
         NSTMT=120
  120  DO WHILE (ierr .ne. -1)
          READ (50, '(A42)', iostat=ierr, err=820, end=150) 
     *          FCHAR 
        end do
        Assign 150 to label 
           NSTMT=150
  150   BACKSPACE(50, iostat=ierr, err=820) 
* 
*          Write info to file 
* 
         Assign 160 to label
          NSTMT=160 
         DO 165 ILN = 1,NL
* 
  160    WRITE (50, 1100, iostat=ierr, err=820) 
     *           HKEEP, WVTB, CPLACE(ILN), SFLUX(ILN), SERR(ILN), 
     *           RPTFQ, DVM(ILN)
  165    CONTINUE 
* 
 1100    FORMAT (L1, L1, A2, G12.6, G12.6, L2, G12.6) 
* 
*         Write EOF 
          Assign 170 to label 
              NSTMT=170 
  170     ENDFILE (50, iostat=ierr, err=820)
* 
              Assign 180 to label 
                   NSTMT=180
  180         CLOSE (50, iostat=ierr, err=820)
* 
       GO TO 900
* 
*     General error checking. 
* 
  820     Call ERMSG (ierr, NSTMT, '     ', *900, k)  
          GO TO label 
* 
  900   RETURN k
      END 
* 
********************************************************************* 
* 
      BLOCK DATA
* 
********************************************************************* 
* 
       LOGICAL HKEEP, PROB, NEXT, FIRE, RPTFQ, CALSRS 
* 
       INTEGER  SORSNM, ERSORS
* 
       REAL     MEDTB, MEDVM
* 
        COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE,
     *                      HKEEP, PROB, SORSNM(5), KPLACE, 
     *                      IDCB(272), NSORS, I, ITIME(5),
     *                      IYEAR, RPTFQ, ERSORS(10), ERWAV(10), KERR,
     *                      ERSQAV(10), CALSRS, IDCBS, TUBNET 
* 
      END 
* 
********************************************************************* 
* 
*       FUNCTION TO OBTAIN UNIVERSAL- OR SIDERIAL TIME. 
*            Returns UT if L = 1, ST if L = 2 (in SECONDS)
*                    Time in decimal year for L = 3 (less 1900.)
* 
********************************************************************* 
* 
      FUNCTION TIME(L)
* 
        INTEGER IT(5) 
        EQUIVALENCE (IT(1),MS), (IT(2),IS), (IT(3),M),
     *              (IT(4),IH), (IT(5),ID)
        DATA  BASEOF / 84 806.882 /, LSTDAY / 0 /,
     *        RATE / 0.002 737 909 3 /
* 
*     Calculate UT
           CALL EXEC (11, IT, IYR)
           TIME = FLOAT(IH*60 + M) * 60.0 + FLOAT(IS) + FLOAT(MS)/100.
             IF (L .LT. 2)  GO TO 900 
             IF (L .EQ. 3)  GO TO 300 
* 
*     Calculate ST. 
            IF (ID .NE. LSTDAY) 
     *        OFFSET = FLOAT((IYR-1979)*365 + (IYR-1977)/4 + ID - 258)
     *                 * 236.55536 + BASEOF + 6644.4
         TIME = TIME + TIME * RATE + OFFSET 
         TIME = TIME - FLOAT(IFIX(TIME/86400.0)) * 86400.0
         GO TO 900
* 
*     Calculate time in decimal YEAR
* 
  300    TIME = ((TIME/86400.) + FLOAT(ID))/365. + FLOAT(IYR) 
         TIME = TIME - 1900.
  900    RETURN 
      END 
* 
********************************************************************* 
* 
*          SUBROUTINE TO ARRANGE FLUXES IN ASCENDING ORDER AND
*               CALCULATE THE MEDIAN. 
*                                 Uses REAL variables. 
* 
********************************************************************* 
* 
         SUBROUTINE MEDIN (LU, RDVM, ICOUNT, MEDVM, DIGVM)
* 
          REAL    DIGVM(1), MEDVM 
* 
           DO 110  J = 1,ICOUNT 
* 
*           Rise thru' array until position of value is found.
               IF ( RDVM .LE. DIGVM(J) )  GO TO 130 
* 
  110    CONTINUE 
* 
           DIGVM(ICOUNT) = RDVM 
                 GO TO 900
* 
*          Shift all subsequent values up the array.
  130        DO 140  K = ICOUNT,J,-1
                     DIGVM(K+1) = DIGVM(K)
  140        CONTINUE 
* 
           DIGVM(J) = RDVM
* 
  900      CONTINUE 
* 
           MIDL = ICOUNT/2
           MEDVM = DIGVM(MIDL)
* 
* 
         RETURN 
      END 
* 
*********************************************************************** 
* 
*        Subroutine to read values of sun rise,set-times and coords 
*             from disc file
* 
*********************************************************************** 
* 
         SUBROUTINE SUNTM (NOWDAY, UHSET, UMSET, UHRISE, UMRISE,
     *                     RASUN, DECSUN, k,*)
* 
         CHARACTER NAMFIL*10
* 
         INTEGER   SHRISE, SMRISE, SHSET, SMSET, UHSET, UMSET, UHRISE,
     *             UMRISE, RHSUN, RMSUN, DAY, YEAR, DATE
* 
         DATA      NAMFIL /'SUNTIM::16'/
* 
*        Open, read and close file
* 
                 Assign 110 to label
                   NSTMT = 110
  110       OPEN (10, file=NAMFIL, iostat=ierr, err=820, status='OLD')
* 
*       Find today's times and coords 
* 
       DO WHILE (NOWDAY .NE. DAY) 
                 Assign 120 to label
                    NSTMT = 120 
  120       READ (10, 1200, iostat=ierr, err=820) DAY, YEAR, MONTH, 
     *                    DATE, SHSET, SMSET, SHRISE, SMRISE, UHSET,
     *                    UMSET, UHRISE, UMRISE, RHSUN, RMSUN, DECSUN 
* 
        END DO
                     Assign 160 to label
                         NSTMT = 160
  160              CLOSE (10, iostat=ierr, err=820) 
* 
            RASUN = (FLOAT(RHSUN) + FLOAT(RMSUN)/60.) * 15. !Decml deg
* 
               GO TO 900
* 
*      Error handling 
* 
  820     Call ERMSG (ierr, NSTMT, '     ', *900, k)  
          GO TO label 
* 
 1200    FORMAT (I3, I4, 12I2, F7.3)
* 
  900   RETURN k
      END 
* 
* 
************************************************************************
* 
*      Subroutine to calculate source angular separation from sun 
*          and to skip source if too close
* 
*********************************************************************** 
* 
         SUBROUTINE CLOSN (RAP, DECP, RASUN, DECSUN, NSORS, ksun,*) 
* 
            DATA  SUNLIM / 20. /
* 
             ksun = 0 
          RADIF = RAP - RASUN 
          DECDIF = DECP - DECSUN
* 
           IF (RADIF .GT. 180.) RADIF = RADIF - 360.
           IF (RADIF .LT. -180.) RADIF = RADIF + 360. 
           IF (DECDIF .GT. 180.) DECDIF = DECDIF - 360. 
           IF (DECDIF .LT. -180.) DECDIF = DECDIF + 360.
* 
C       PRINT '("RAP, RASUN, DECP, DECSUN, RADIF, DECDIF",6(2X,F6.3))', 
C    *           RAP, RASUN, DECP, DECSUN, RADIF, DECDIF
* 
         If ((ABS(RADIF) .LT. SUNLIM) .AND. 
     *       (ABS(DECDIF) .LT. SUNLIM))  then 
               PRINT '(/"Source no.",I4," too close to sun"/
     *                  "RA and DEC angular separation from sun resp.", 
     *                   2(2X,F6.2),/ 
     *                  "Source skipped")', NSORS, RADIF, DECDIF
* 
                 ksun = 1 
          endif 
* 
        RETURN ksun 
        END 
* 
********************************************************************* 
* 
*      SUBROUTINE TO WRITE SOURCE INFO ONTO DISC FILE.
*         File name RESFIL generated in main program. 
* 
********************************************************************* 
* 
      SUBROUTINE WINFO (LU, NFRQ, RESFIL, WVTB, WAVE, 
     *                  NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, k,*)  
* 
       CHARACTER CPLACE(20)*2, NAMRFL*10
* 
       LOGICAL   HKEEP, PROB, RPTFQ, NEXT, FIRE, WVTB, CALSRS 
* 
       INTEGER   RESLT(21), RESFIL(3), IDCB(272), ITIME(5), SORSNM(5),
     *            ERSORS(10)
* 
       REAL      WAVE(1), ERWAV(10), ERSQAV(10), MEDTB, MEDVM,
     *           SFLUX(20), SERR(20), DVM(20) 
* 
       COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, 
     *                  HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                  I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV,
     *                  KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
       DATA      IBLANK / 2H   /
* 
       If (HKEEP .OR. WVTB) then
* 
*          Open file
* 
              Assign 110 to label 
                NSTMT=110 
  110        OPEN (50, file=NAMRFL, iostat=ierr, err=820, status='OLD') 
* 
*             Find EOF
               Assign 120 to label
                  NSTMT=120 
  120         Do while (ierr .ne. -1) 
                 READ (50, '(A42)', iostat=ierr, err=820, end=150)
     *                 FCHAR
              end do
* 
              Assign 150 to label 
                 NSTMT=150
  150         BACKSPACE(50, iostat=ierr, err=820) 
* 
                 Assign 160 to label
                    NSTMT=160 
  160        If (HKEEP) then
* 
*              Get decimal time in years. 
* 
                 DECTM = TIME(3)
                 SIDTIM = TIME(2)/3600.    !Siderial time in decimal hrs
* 
*              Write housekeeping 
* 
                 WRITE (50, 1100, iostat=ierr, err=820) 
     *                             HKEEP, NSORS, (SORSNM(L), L=1,5),
     *                             DECTM, NFRQ, CALSRS, 
     *                             SIDTIM 
 1100            FORMAT(L1, I3, 5A2, F8.4, I2, L2, F12.6) 
* 
             else if (WVTB) then
* 
*                  Write wavelength and ave. tube DVM value.
* 
                     WRITE (50, 1200, iostat=ierr, err=820) 
     *                                 HKEEP, WVTB, WAVE(I), MEDTB, 
     *                                 TBDEV, (IBLANK, J=1,5) 
 1200                FORMAT(L1, L1, F6.1, 2G12.6, 5A2)
* 
                 NL = 0 
                 WVTB = .FALSE. 
* 
             endif
* 
*                 Write EOF 
                  Assign 180 to label 
                     NSTMT=180
  180             ENDFILE (50, iostat=ierr, err=820)
* 
                  Assign 190 to label 
                       NSTMT=190
  190             CLOSE (50, iostat=ierr, err=820)
* 
       endif
* 
         If (.NOT. HKEEP) then
* 
*         Assign track info to array for writing to file at end of freq.
* 
            NL = NL + 1 
            WRITE (CPLACE(NL), '(A2)') KPLACE 
            SFLUX(NL) = SORSJY
            SERR(NL) = ERROR
            DVM(NL) = MEDVM 
* 
         endif
* 
       GO TO 900
* 
*     General error checking. 
* 
  820     Call ERMSG (ierr, NSTMT, '     ', *900, k)  
          GO TO label 
* 
  900     CONTINUE
* 
       RETURN k 
      END 
* 
********************************************************************* 
* 
*        SUBROUTINE TO CONTROL DVM's AND NOISE TUBE, AND CALCULATE
*            AVERAGE FLUX READINGS OF SOURCE. 
*                                 Calls subroutine MEDIN. 
* 
*         Uses Fluke DVM 8840 
* 
********************************************************************
* 
$ALIAS/DOUT1/,NOALLOCATE
      SUBROUTINE FLUX (LU, TUFLUX, WAVE)
* 
         LOGICAL  NEXT, FTUBE, FIRE, HKEEP, PROB, RPTFQ, CALSRS 
* 
         INTEGER  IBUF(4),  HASL, SORSNM(5), IDCB(272), 
     *            ITIME(5), ERSORS(10)
* 
         REAL     TUFLUX(1), JYDVM, WAVE(1), DIGVM(651), MEDTB, 
     *            MEDVAL, ERWAV(10), ERSQAV(10), PREVTB(6), TBNOM(6), 
     *            PREVER(6), MEDIAN 
* 
         REAL*8   AVDVM, SQAV, AVDSQ, DIFF, DSTDEV, totdvm, sumsq, sqdvm
* 
      COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVAL, NEXT, FIRE, 
     *                    HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                    I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV,
     *                    KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
         COMMON  /DOUT1/ ISERVO 
* 
         DATA   NSMPL / 650 /,  NTSAM / 650 /,  !Remember change DIGVM
     *          TBNOM / -.0564,  -.0123,  .0202,   0.01,  0.01,  0.01 / 
* 
           FTUBE =  .FALSE. 
           NEXT = .FALSE. 
           IFAIL = 0
           NTFAIL = 0 
* 
           IF ( I .EQ. 1)  IFQ = 2
           IF ( I .EQ. 2)  IFQ = 1
           IF ( I .EQ. 3)  IFQ = 3
           IF ( I .EQ. 4)  IFQ = 4
           IF ( I .EQ. 5)  IFQ = 5
           IF ( I .EQ. 6)  IFQ = 5
* 
*       Select DVM inputs, DIRECT, same freq on both. 
* 
  100     ISEL = (IFQ * 2 - 1) * 11B
          IF (IFQ .EQ. 5) ISEL = 66B           ! GPR selected 
          CALL EXEC (2, 113B, ISEL, 1, 5, 5)
          CALL EXEC (12, 0, 2, 0, -1)  ! Wait 1 second for settling 
* 
*       Set up DVM. Default values, medium sampling rate
* 
           WRITE (35,'("*S1")') 
* 
               NSAM = NSMPL 
               IF ( KPLACE .EQ. 2HFN )  NSAM = NSMPL/2
* 
*          Reset ordered array of DVM readings, DVM totals, etc.
  110         DO  120  JJ = 1,NSMPL+1 
                       DIGVM(JJ) = 0.0
  120             CONTINUE
                       TOTDVM = 0.0 
                       SUMSQ = 0.0
* 
*       Loop to read DVM and average NSAM samples.
* 
           DO  200  NN = 1,NSAM 
* 
                READ (35,*) RDVM
* 
*      Keep running total of readings, arranging in order to calc median
* 
                   CALL MEDIN (LU, RDVM, NN, MEDIAN, DIGVM) 
* 
                        TOTDVM = TOTDVM + RDVM
                        SQDVM = RDVM*RDVM 
                        SUMSQ = SUMSQ + SQDVM 
* 
  200    CONTINUE 
* 
*                   Turn noise tube off 
                      If (FTUBE)  then
                              CALL EXEC (2, 113B, 0, 1, 3, 3) 
                      endif 
* 
*        Calculate average and standard deviation.
* 
                  COUNT = NSAM
                  COUNT2 = NSAM/2 
                  AVDVM = DBLE(TOTDVM / COUNT)
                     SQAV = DBLE(SUMSQ/COUNT) 
                     AVDSQ = AVDVM * AVDVM
* 
                   DIFF = SQAV - AVDSQ
                      If (DIFF .LT. 0.) DIFF = 0. 
                   DSTDEV = SQRT( DIFF )
                   STDEV = SNGL(DSTDEV)/SQRT(COUNT2)
* 
*                  New Fluke 8840 DVM connections opposite to old DVM 
*                      Change for consistency with analysis program 
C                  MEDIAN = -1. * MEDIAN
* 
               If (FTUBE) then
                      TBDEV = STDEV 
                      MEDTB = MEDIAN
                 else 
                      VALDEV = STDEV
                      MEDVAL = MEDIAN 
               endif
* 
*        Check max value calculated, for 6 sig fig accuracy 
             If ( SQAV .GT. 8.388E07 )  then
                  KERR = KERR+1 
                     If ( KERR .LE. 10 )  then
                             ERSORS(KERR) = NSORS 
                          If (FTUBE) ERSORS(KERR) = ERSORS(KERR)+1000 
                             ERWAV(KERR) = WAVE(I)
                             ERSQAV(KERR) = SNGL(SQAV)
                     endif
             endif
* 
*          Check for DVM zero.
             If (STDEV .EQ. 0.0)  then
                       PRINT '("DVM ZERO. Trying again.")'
                         IFAIL = IFAIL + 1
* 
                         If (IFAIL .GT. 3) then 
                            PRINT '("Too many problems. Try next freq")'
                               NEXT = .TRUE.
                               GO TO 988
                         else 
                             If (FIRE) FTUBE = .FALSE.
                             GO TO 100
                         endif
             endif
* 
* 
       If (FIRE) then 
* 
*            Return to fire tube as necessary 
             If ( .NOT. FTUBE )  then 
* 
                    FTUBE = .TRUE.
                    NSAM = NTSAM
*                    Fire tube and wait 3 sec for trace to settle 
                        IFREQ = IFQ+1 
*     fix for 6.1 , 2.8 cm   4.5 cm 
                        if (i .eq. 1 .or. i .eq. 5 .or. i .eq. 6) 
     *                      ifreq = 2 
                        IF ( IFQ .EQ. 1 ) IFREQ = 1       ! 3.4cm tube
                        CALL EXEC (2, 113B, IFREQ, 1, 3, 3) 
                        CALL EXEC (12, 0, 2, 0, -3) 
                     GO TO 110
             else 
                     FTUBE = .FALSE.
* 
*      Check that noise tube fired. Nominal minimum set as 2*RMSnoise 
*    change to 4 times 1987 dec 21 mjg
                    TUBNET = MEDTB - MEDVAL       !Net tube in DVM units
* 
                    TLEVL = 4. * STDEV * SQRT(COUNT2) 
* 
                 If ( ABS(TUBNET) .LT. TLEVL )  then
                      PRINT '(/"Noise diode fired ? Trying again.",/ 
     *                         "STDEV, TBDEV, VALDEV",3(2X,G12.4),/
     *                         "COUNT, TLEVL", 2(2X,G12.4),/ 
     *                         "MEDIAN, MEDTB, MEDVAL, TUBNET ", 
     *                             4(2X,G12.4))', 
     *                         STDEV, TBDEV, VALDEV, COUNT, TLEVL,
     *                         MEDIAN, MEDTB, MEDVAL, TUBNET
* 
                        NTFAIL = NTFAIL + 1 
* 
*                     If no. errors is >3, use nominal/previous tube
*                                     value, and continue.
                             If (NTFAIL .GT. 3) then
                                 TUBNET = PREVTB(IFQ) 
                                 TBDEV = PREVER(IFQ)
                                  If (TUBNET .EQ. 0.0) then 
                                      TUBNET = TBNOM(IFQ) 
                                      TBDEV = .07 * TUBNET/TUFLUX(I)
                                  endif 
                                 PRINT '("Using nominal/previous ", 
     *                                   "value of ",G12.4,"+-",G12.4,
     *                                   " DVM units")', TUBNET, TBDEV
                             else 
                                   GO TO 100
                             endif
                 endif
                         PREVTB(IFQ) = TUBNET 
                         PREVER(IFQ) = TBDEV
* 
*                    Correction factor of Jy/DVM unit 
                       JYDVM = TUFLUX(I)/ABS(TUBNET)
             endif
         endif
* 
*     Convert measured values to Jy 
                ERDVM = SQRT( TBDEV*TBDEV + VALDEV*VALDEV)
          SORSJY = MEDVAL * JYDVM 
          ERROR = ERDVM * JYDVM 
            PRINT '(F6.3,"+-",F5.3)', SORSJY, ERROR 
* 
  988      FIRE = .FALSE. 
      RETURN
      END 
* 
**********************************************************************
* 
*          Subroutine to calculate antenna limits 
* 
*********************************************************************** 
* 
      SUBROUTINE LIMIT (HA,DEC,BELOW) 
* 
*     Find if command angles are below the horizon
*             Copy of subroutine CMDLM in &STEER
*        HA      input current command hour angle 
*        DEC     input current command declination
* 
       LOGICAL BELOW
* 
*          DEC must be in range -90, +90
                  If (DEC .GT. 90) then 
                      do 110 while (DEC .GT. 90.) 
                          DEC = DEC - 180.    
  110                 end do
                  endif 
                  If (DEC .LT. -90.) then 
                      do 115 while (DEC .LT. -90.)  
                          DEC = DEC + 180.  
  115                 end do
                  endif 
* 
*     Limit command HA for real DEC 
*     ----------------------------- 
      halim = HA
      realdec = DEC 
      if (realdec .gt. 180.0) realdec = realdec - 360.0 
      if (halim .lt. 0.0) then
*         limit command HA in the east
          alimit = -88.0
          if (realdec .gt. -15.0) alimit = 0.45*realdec - 81.25 
          if (realdec .gt. +25.0) alimit = realdec - 95.0 
          if (halim .lt. alimit)  halim  = alimit 
      else
*         limit command HA in the west
          alimit = 88.0 
          if (realdec .gt.  -5.0) alimit = -0.3*realdec + 86.5
          if (realdec .gt.  +5.0) alimit = -realdec + 90.0
          if (halim .gt. alimit)  halim  = alimit 
      endif 
* 
*     Limit command DEC for real HA 
*     ----------------------------- 
* 
      declim = DEC
*     limit command dec in the north
      alimit =  45.0
      realha = HA 
      if (realha .gt. 180.0) realha = realha - 360.0
      if (realha .lt. 0.0) then 
*         limit command dec in the east and north 
          if (realha .lt. -50.0) alimit = realha + 95.0 
          if (realha .lt. -70.0) alimit = 2.222*realha + 180.556
      else
*         limit command dec in the west and north 
          if (realha .gt. 45.0) alimit = -realha + 90.0 
          if (realha .gt. 85.0) alimit = -3.333*realha + 288.333
      endif 
      if (declim .gt. alimit) declim = alimit 
*     limit command dec in the south
      if (declim .lt. -83.0) declim = -83.0 
* 
      BELOW = ((HA .NE. HALIM) .OR. (DEC .NE. DECLIM))
* 
      return
      end 
* 
* 
*********     VERSION  <960423.1538>
* 
********************************************************************* 
* 
*        Subroutine to display errors 
* 
********************************************************************* 
* 
       SUBROUTINE ERMSG (ierr, NSTMT, SEGNAM, k,*)
* 
       CHARACTER SEGNAM*5 
* 
       LOGICAL AOK
* 
         PRINT '("Error ",(I4)," at statement",(I4)," in ",(A5))', ierr,
     *                          NSTMT, SEGNAM 
            k=1 
       RETURN k 
       END
* 
**************************************************************************
           INCLUDE &RHYP::16
           INCLUDE &RDSYS::16 
           INCLUDE &ERFIL::16 
           INCLUDE &OBSYN::16 
