FTN77,S 
$FILES 2,2
      PROGRAM TNFQS (3,80)
********************************************************************* 
*                                                                   * 
*     PROGRAM TO TRACK SOURCES ON AND OFF THE BEAM at 4 frequencies * 
*     SOURCES READ FROM A SOURCE FILE. COPY OF TNFPC 1991/05/30     * 
*                                                                   * 
*     mod JFHQ 1991 Jul 8 : Runs similarly to TAEAQ but with HA     * 
*                           limits from STEER as in TNFPC           * 
*                                                                   * 
*     Use of Fluke 8840 DVM 1985/10/24                              * 
*                                                                   * 
*     WRITTEN BY DCB 1982/04/30 FOR LATEST MOD SEE VERSION BELOW    * 
*     Precession calcs changed 1984/09/14                           * 
*     Modified by CF 1988/02/29 to allow interrupt by SCHDL;        * 
*     statements from TONSH used. Updated JQ 1992/02/25             * 
*     Modified by JQ 1991/07/11 to use DRIVE as a son program.      * 
*                                                                   * 
********************************************************************* 
* 
      PARAMETER (NFRQ = 4)
* 
      CHARACTER KDTYPE(2)*8, CPLACE(11)*2, NAMRFL*10, HYPANS*2
* 
      LOGICAL AOK, START, CHK, HKEEP, PROB, NEXT, FIRE, S13OFF, 
     *        RPTFQ, BADTRK, WVTB, CALSRS, IFBRK, CLSUN, S18OFF,
     *        NO3P6, BELOW, KDECML, PAGEFD, HYPFLT, NOWDAY, OBSDONE 
* 
      INTEGER ITIME(5), IPRAM(5), FILNAM(3), SWIN, DPRC2(3),
     *        FDCB(144), SORSBF(40), SORSNM(5), IANG(5), ALARM(3),
     *        RESFIL(3), IDCB(272), IDUMY(2), ERSORS(10), IAB(2)
* 
      REAL    FNOFS(NFRQ), HPOFS(NFRQ), 
     *        RAOFS(NFRQ),  DEOFS(NFRQ), WAVE(NFRQ),
     *        TUFLUX(NFRQ), BMSEP(NFRQ),
     *        ERWAV(10), ERSQAV(10), MEDTB, MEDVM,
     *        SFLUX(11), SERR(11), DVM(11)
* 
      COMMON  / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, 
     *                  HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                  I, ITIME, IYEAR, RPTFQ, BADTRK, 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) or to cross-over (dual) 
*        BMSEP  is the angular separation (peak to peak) of dual beams
* 
*        TUFLUX is the NOISE TUBE equivalent flux in Jansky.
* 
*        ISIZE, ITYPE, ISECU, ICR refer to the RESULTS FILE.
*        Results are written on to RESFIL which has form QSday. 
* 
      DATA WAVE  /  6.0,     3.6,      13.0,   18.0  /, 
     *     FNOFS /  0.18,    0.230,    0.4,    0.595 /, 
     *     HPOFS /  0.082,   0.048,    0.162,  0.247 /, 
     *     RAOFS /  0.084,   0.144,    0.071,  0.070 /, 
     *     DEOFS / -0.214,  -0.603,    0.413,  1.750 /, 
     *     BMSEP /  0.254,   0.258,    0.0,    0.0   /, 
     *     TUFLUX/  24.65,   191.77,   37.99,  140.0 /, 
     *     ISIZE / 100 /,  ITYPE /  3 /, ISECU / 0 /, ICR / 15 /, 
     *     RESFIL / 2HQS, 2H00, 2H   /, 
     *     CHK / .FALSE. /, LU / 7 /, 
     *     ALARM / 2HAL, 2HAR, 2HM  /,
     *     DPRC2 / 2HDP, 2HRC, 2H2  /,
     *     KDTYPE / 'DECIMAL ', 'HMS, DMS' /
* 
*       Initialise resources
* 
           CALL FSYSU (LU, LU)
           CALL ISSR (0)                ! Reset S-register
           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 
* 
*   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 (TNFQS) : DAY ",I3,",",I4
     *        /3X,46"=" 
     *       //3X," Version <960618.0910>"
     *       //3X," Source file must use 1950.0 coordinates. ", 
     *       //3X," Set S register bit 0 ON to suspend 3.6 cm readings" 
     *        /22X," 1 ON to suspend 6.0 cm readings" 
     *        /22X," 2 ON to suspend 13.0cm readings" 
     *       //22X," 9 ON to repeat current FREQ."
     *        /22X," 10 ON to repeat current SOURCE " 
     *       //22X," 13 ON to SUSPEND the program"
     *        /22X," 14 ON to SKIP the next source "
     *        /22X," 15 ON to END PROGRAM.",//) 
* 
*      Check Hyperbola is untilted and correctly focussed 
* 
         CALL CHKHYP(HYPFLT)
         IF (HYPFLT) CALL EXEC(10,ALARM)
  100    IF (.NOT.HYPFLT) GO TO 110 
           PRINT *,'Correct and hit <Return> to continue' 
           PRINT *,'             or   "OK"   to override _' 
           READ (LU,'(A2)') HYPANS
           IF (HYPANS.EQ.'OK' .OR. HYPANS.EQ.'ok') then 
              HYPFLT=.FALSE.
           else 
              CALL CHKHYP(HYPFLT) 
           endif
         GO TO 100
* 
  110    CALL BITST           !Choose operating freqs,set S-reg 
* 
*      Sets bits to nightime values so signal that programs thinks is night 
* 
         NOWDAY = .FALSE. 
* 
         CALL RNALC(IRN)      ! Allow scheduling   ** inserted by CF 5/88 
  119  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(/3X," UT of sunset and sunrise in DECIMAL hrs : ",
     *             2F6.2) 
* 
*       Subtract 9 mins from sunrise so that measurement ends before sunrise
* 
           SUNRIS = SUNRIS - 0.15 
* 
*           Convert to seconds. 
              SUNRIS = SUNRIS * 3600. 
              SUNSET = SUNSET * 3600. 
* 
*     Decide whether checking BEAM PARAMETERS.
* 
       WRITE (LU,2100)
 2100  FORMAT(/3X," Necessary to check BEAM PARAMETERS? Yes(T) _")
* 
         READ (LU,1080) CHK 
* 
           IF ( .NOT. CHK )  GO TO 131
* 
*      CHECK THE BEAM PARAMETERS FOR EACH FREQUENCY 
*      -------------------------------------------- 
      DO 130 I=1,NFRQ 
* 
*        Bits 0,1,2, 3 set for skip 3.6,6.0,13.0, 18.0 cm. measurements 
* 
               ISWIT = SWIN(0)
               ISWIT = ISWIT .AND. 000017B
                  GO TO (133, 132, 134, 135) I
* 
  132              ISWIT = ISWIT .AND. 1B 
                   IF ( ISWIT .EQ. 1B )  GO TO 130
                       GO TO 139
  133                ISWIT = ISWIT .AND. 3B 
                     IF ( ISWIT .GE. 2B )  GO TO 130
                       GO TO 139
  134                ISWIT = ISWIT .AND. 7B 
                     IF ( ISWIT .GE. 4B )  GO TO 130
                      GO TO 139 
  135                ISWIT = ISWIT .AND. 17B
                     IF ( ISWIT .GE. 10B)  GO TO 130
* 
  139    CALL PARAM (LU, WAVE, I, RAOFS, DEOFS, FNOFS, HPOFS, 
     *               BMSEP) 
* 
  130 CONTINUE
* 
  131   CONTINUE
* 
  300   CONTINUE
         WRITE (LU,3000)
 3000    FORMAT(//3X," Name of source file ? _")
         READ  (LU,3100) FILNAM 
 3100    FORMAT(3A2)
* 
*            Find the number of the starting source 
  320  WRITE (LU,3130)
 3130  FORMAT(/3X," First source number ? _") 
       READ  (LU,*)  NFIRST 
* 
        PRINT '(/4X,"Source coordinates in form decimal degrees (T)," 
     *              " or hms,dms (F) ? _")' 
        READ *, KDECML
               If (KDECML) then 
                   KOORD = 1
               else 
                   KOORD = 2
               endif
* 
*         Confirm that this is correct
* 
      WRITE (LU,3150)  (FILNAM(J), J=1,3), KDTYPE(KOORD), NFIRST
 3150   FORMAT(/3X," Using source file ",3A2,/
     *          3X," with ",A8," coordinates. ",/ 
     *          3X," Starting at source ",I4,// 
     *          6X," OK (T or F) ? _")
          READ  (LU,1080) AOK 
         IF ( .NOT. AOK )     GO TO 300 
* 
*    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 300 
* 
*          File opened successfully. Close again temporarily. 
  350  CALL CLOSE (FDCB,IERR) 
* 
        NREC = 0
        NSKIP = 0 
        NRECSKP = 0 
        NENDFL = 0
        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
 8400             FORMAT(/" FMGR ERROR ",I4," CHECK STATUS. OK (T)?_")
                    READ (LU,1080) AOK
                    IF ( .NOT. AOK )   GO TO 900
            GO TO 810 
* 
*     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(/2X," Results are in disc file ",3A2)
* 
*     Signal new header by setting lines on page to end of page value 
*     and signal that the page is not yet fed 
* 
         NPRINT=50
         PAGEFD=.FALSE. 
* 
*     Read the parameters of 1 source. Close the file after selection 
* 
*  START OF LOOP FOR EACH SOURCE. 
* 
  500   CONTINUE
*                Check if BIT 15 has been set 
* 
           IF(ISSW(15) .LT. 0)     GO TO 900
       NREC = NREC + 1
* 
*            Allow program to suspend if bit 13 set or BREAK
* 
            CALL SUSPD (IRN, NREC, PAGEFD)              ! SCHDL suspend 
* 
*              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 300 
* 
*   Before processing source check for end of page and feed page & signal 
* 
  520 IF ((NPRINT.GE.50) .AND. (.NOT. PAGEFD)) then 
         PRINT '(A1,"_")', CHAR(14B)              ! Form Feed 
         PAGEFD=.TRUE.
      endif 
* 
*   If a pagefeed has occurred then print a header at top of page and reset 
* 
      IF (PAGEFD) then
         PRINT '("No.  Source    Start UT    HA     Freq ", 
     *            " Flux +- Error ... etc.")' 
         NPRINT=0 
         PAGEFD=.FALSE. 
      endif 
* 
*     Position pointer in file -then read line of ASCII data
* 
        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 ") 
         GO TO 320
* 
  535  IF( LEN .GT. 0)  GO TO 540 
* 
           IF (NSKIP.EQ.0) then 
              WRITE (LU,5130) 
 5130         FORMAT (/" END OF SOURCE FILE. RETURN TO No. 1_") 
              NPRINT=NPRINT+1 
           endif
           NENDFL=NREC-1
           NREC = 0 
         GO TO 500
* 
*      Convert the ASCII data off the source file to BINARY 
* 
  540 If (KDECML) then
             CALL CODE
             READ (SORSBF,5205)  NSORS, SORSNM, RA0, DEC0,
     *                           CALSRS, NO3P6
 5205        FORMAT(I3, 5A2, 2F9.3, L2, L1) 
* 
      else
            CALL CODE 
             READ (SORSBF,5200)  NSORS, SORSNM, RH, RM, RS, 
     *                           DD, DM, DS, CALSRS, NO3P6
 5200        FORMAT(I3, 5A2, F2.0, F3.0, F5.1, F4.0, 2F3.0, L2, L1) 
* 
       endif
* 
*       Continue with next source if not starting 
      IF ( .NOT. START )   GO TO 560
* 
*       If starting, check if wanted source has been found
      IF ( NSORS .EQ. NFIRST)    GO TO 560
* 
*       Otherwise increment NREC and read next line of file 
      NREC = NREC + 1 
      GO TO 520 
* 
  560 START = .FALSE. 
* 
*      Calculate source coordinates RA0,DEC0 (ie. 1950) in decimal degrees
* 
      IF (.NOT. KDECML) then
         RA0 = (( RH*60.0 + RM ) * 60.0 + RS)/240.0 
         IF ( DD .EQ. 0 ) GO TO 580 
            DM = SIGN(DM,DD)
            DS = SIGN(DS,DD)
  580    DEC0 = DD + DM/60.0 + DS/3600.0
         IF ((DD.EQ.0) .AND. ((SORSBF(13).AND.77400B).EQ.26400B)) 
     *      DEC0 = -DEC0
         IF ( DEC0 .GT. 270.0)      DEC0 = DEC0 - 360.0 
       endif
* 
*    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)
* 
*    Obtain 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 
* 
*    Calculate source HA. to allow skips or waits 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.
* 
*   Print source file information if not in skip back mode
* 
      IF (NSKIP.EQ.0) then
         CALL EXEC (11,ITIME,IYEAR) 
         PRINT '(/I3,5A2,1X,3I3,2X,F5.2,"_")',
     *    NSORS, SORSNM, (ITIME(L), L =4,2,-1), HA
         NPRINT=NPRINT+1
      endif 
* 
*   Check offset of source from sun during daytime
* 
       UTNOW = TIME(1)
       IF (SUNRIS.LT.UTNOW .AND. UTNOW.LE.SUNSET) then
          CALL CLOSN (RAP, DECP, RASUN, DECSUN, NSKIP, CLSUN) 
          IF (CLSUN) then 
* 
*          Skip source and reset skip back mode if this is awaited source 
* 
             IF (NREC.EQ.NRECSKP) NSKIP = 0 
             NREC = NREC+1
             GO TO 520
          endif 
       endif
* 
*   Find western and eastern horison mask (as used in STEER) & compare
* 
       HAEAST = HALIM(-90.0,DECP)/15.0
       HAWEST = HALIM(+90.0,DECP)/15.0
* 
*     Observation must start 9 minutes before West limit
* 
       IF ((HA+0.15) .GT. HAWEST) then
          IF (NSKIP.EQ.0) WRITE (LU,5950) HAWEST
 5950        FORMAT(' has set below ',F4.2,'. Source skipped_') 
* 
*       Return to process next source in file 
* 
          IF (NREC.EQ.NRECSKP) NSKIP = 0
          NREC=NREC+1 
          GO TO 520 
       endif
* 
*    Print source details now if in skip back mode as source is valid 
* 
       IF (NSKIP.NE.0) then 
          CALL EXEC (11,ITIME,IYEAR)
          PRINT '(/I3,5A2,1X,3I3,2X,F5.2,"_")', 
     *     NSORS, SORSNM, (ITIME(L), L =4,2,-1), HA 
          NPRINT=NPRINT+1 
       endif
* 
*    Check if risen far enough above eastern horizon
* 
       IF (HA .LT. HAEAST+0.15) then
          WRITE (LU,5951) HAEAST+0.15 
 5951     FORMAT(' yet to rise above ',F5.2,'. _')
* 
*       Check wait time in minutes until it rises 
* 
          MWAIT = -(HA - HAEAST - 0.15) * 60.0
          IF (MWAIT.GT.10.0) then 
* 
*          Since wait time is long enough, skip back to measure while waiting 
* 
             IF (NREC.NE.NRECSKP .OR. NSKIP.EQ.0) then
* 
*             First pass for source : simply wait suitable no of sorces 
* 
                NSKPOLD = 0 
                NSKIP = INT(MWAIT/10.)
                OBSDONE = .FALSE. 
             else 
* 
*             Second pass at least : adjust NSKIP by previous time taken
* 
                NSKPOLD = NSKIP 
                IF (SIDHRS.LT.OLDSID) OLDSID = OLDSID-24.0
                NSKIP = INT((MWAIT-(SIDHRS-OLDSID)*60.)/10.)+NSKIP
                OBSDONE = ((SIDHRS-OLDSID).GT.0.05) ! i.e. more than 3 mins 
             endif
* 
*          Save details for possible second pass
* 
             NRECSKP = NREC 
             OLDSID = SIDHRS
* 
*          Allow skip back before end of file but only one pass 
* 
  585        IF (NENDFL.NE.0 .AND. NSKIP.GE.NENDFL) NSKIP = NENDFL-1
             NREC = NREC + NENDFL - NSKIP 
             IF (NREC.GT.NENDFL) NREC = NREC - NENDFL 
             IF (NREC.LE.0) then
                NREC = NRECSKP
  590              NREC = NREC + 1
                   CALL POSNT(FDCB,IERR,NREC,1) 
                   CALL READF(FDCB,IERR,SORSBF,40,LEN)
                IF (LEN.GT.0) GO TO 590 
                NENDFL = NREC - 1 
                NREC = NRECSKP
                GO TO 585 
             endif
             IF (OBSDONE .OR. NSKIP.GT.NSKPOLD) then
* 
*             Only skip back if NSKIP covers more sources than last pass
*              or if a source was actually observed on the last pass. 
* 
                PRINT '("Skipping back",I3," source(s)_")',NSKIP
                GO TO 520 
             else 
* 
*             Otherwise reset NREC to awaited source and simply wait
* 
                NREC = NRECSKP
             endif
          endif 
* 
*       Wait till source rises but not if drive time will cover it
* 
          IF (MWAIT.GT.60) CALL EXEC(10,ALARM)
          WRITE (LU,*) 'Waiting ',MWAIT,' minutes_' 
          IF (MWAIT.GT.1.0) CALL RNCLW(IRN, PAGEFD, MWAIT)
* 
*       Reprint source details with new time
* 
          RAHRS = RAP / 15. 
          SIDHRS = TIME(2) / 3600.
          HA = SIDHRS - RAHRS 
          CALL EXEC (11,ITIME,IYEAR)
          PRINT '(/I3,5A2,1X,3I3,2X,F5.2,"_")', 
     *         NSORS, SORSNM, (ITIME(L), L =4,2,-1), HA 
          NPRINT=NPRINT+1 
      endif 
* 
*   Close file now that a source has been found & reset skip back if it 
*    is the awaited source
* 
         CALL CLOSE (FDCB,IERR) 
         IF (NREC.EQ.NRECSKP) NSKIP = 0 
* 
  600 CONTINUE
* 
*      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
       CALL OBSOK 
* 
*    Check for sunrise or sunset
* 
       UTNOW = TIME(1)
       IF ((SUNRIS.LT.UTNOW) .AND. (UTNOW.LE.SUNSET)
     *     .AND. (.NOT.NOWDAY)) then
* 
*       Sunrise so set 13 and 18 cm observations off
* 
          S13OFF=(ISSW(2).GE.0) 
          S18OFF=(ISSW(3).GE.0) 
          ISWIT=SWIN(0) 
          ISWIT=ISWIT .OR. 000014B
          CALL SWOUT(ISWIT) 
          NOWDAY = .TRUE. 
       endif
* 
       IF ((UTNOW.LE.SUNRIS) .OR. (SUNSET.LT.UTNOW) 
     *     .AND. (NOWDAY)) then 
* 
*       Sunset so reset 13 and 18 cm observations back on 
* 
          ISWIT=SWIN(0) 
          IF (S13OFF) ISWIT = ISWIT .AND. 177773B 
          IF (S18OFF) ISWIT = ISWIT .AND. 177767B 
          CALL SWOUT(ISWIT) 
          NOWDAY = .FALSE.
       endif
* 
* 
      DO 700   I=1,NFRQ 
* 
*       Skip 3.6 cm meas on designated sources
* 
           IF ( NO3P6 .AND. WAVE(I) .EQ. 3.6 )  GO TO 700 
* 
*     Bits 0, 1, 2, 3  set for skip 3.6, 6.0, 13.0, 18.0 cm. meas 
               ISWIT = SWIN(0)
               ISWIT = ISWIT .AND. 000017B
                  GO TO (702, 701, 703, 704) 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
* 
*       Calculate antenna coords for each track and then track source.
*          Correct for BEAM OFFSETS 
* 
  711      ONDEC= DECP + DEOFS(I) 
           ONRA = RAP + RAOFS(I)/COS(ONDEC*0.017453293) 
           SEPFAC = (BMSEP(I)/2)/COS(ONDEC*0.017453293) 
* 
         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 
*     TRACKING AT FIRST NULL. 
*          Calculate coordinates: 
* 
        TRA = ONRA + SEPFAC 
        TDEC= ONDEC + FNOFS(I)
        KPLACE = 2HFN 
* 
        FIRE = .TRUE. 
        WVTB = .TRUE. 
        BADTRK = .FALSE.
* 
       CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, NPRINT, 
     *             LU, NFRQ, TUFLUX, RESFIL, 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, NPRINT, 
     *               LU, NFRQ, TUFLUX, RESFIL, NAMRFL,
     *               SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
*      At other FIRST NULL point
* 
         TRA = ONRA + SEPFAC
         TDEC= ONDEC - FNOFS(I) 
         KPLACE = 2HFN
* 
         CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, NPRINT, 
     *              LU, NFRQ, TUFLUX, RESFIL, NAMRFL, 
     *              SFLUX, SERR, DVM, CPLACE, NL) 
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
*       Write out nett fluxes 
* 
         FNAV = (42./123*SFLUX(1)+81./123*SFLUX(3)) 
         FNER = SQRT( (42./123*SERR(1))**2 +
     *                (81./123*SERR(3))**2   )
         ONFLUX = SFLUX(2)-FNAV 
         ONER = SQRT((SERR(2)*SERR(2))+ 
     *               (FNER*FNER)) 
         PRINT '(4X,F4.1,1X,F6.3,"+-",F5.3,"_")', 
     *       WAVE(I), ONFLUX, ONER
* 
*    Write fluxes etc from each position to file RESFIL 
* 
       CALL WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM,
     *             NL, HKEEP, WVTB, RPTFQ, BADTRK, *900,k)
* 
*    Bit 9 set for repeat of current frequency. 
* 
               RPTFQ = .FALSE.
         IF ( ISSW(9) .GE. 0)   GO TO 700 
               RPTFQ = .TRUE. 
             GO TO 710
* 
  700 CONTINUE
* 
*       Bit 10 set for repeat of current source.
* 
         IF ( ISSW(10) .LT. 0)   GO TO 690
* 
*       Allow SCHDL to interrupt here if it wants to
* 
         CALL RNCLW (IRN, PAGEFD, 0)       ! SCHDL call 
* 
*      Go back to run for next source.
* 
      GO TO 500 
  900 CONTINUE
* 
*      Park at Zenith with no pointing corrections and no wait
* 
         CALL TRACK (2, 0.0, 334.114, .FALSE., .FALSE.) 
* 
           IF (KERR .EQ. 0)  GO TO 910
* 
             WRITE (LU,9960)
 9960        FORMAT(//" Limit for 6 sig fig accuracy exceeded at:"/ 
     *                "    Source no.    Wave.     Value. ")
               DO 905  KKK = 1,KERR 
* 
                     IF ( KKK .LE. 10 )  GO TO 904
                        WRITE (LU,9965) KERR
 9965                   FORMAT(" Limit exceeded >10 times ...", I3, 
     *                         " times, in fact. ") 
                     GO TO 906
  904             WRITE (LU,9970) ERSORS(KKK), ERWAV(KKK),
     *                            ERSQAV(KKK) 
 9970             FORMAT(6X, I4, 8X, F6.1, 5X, G12.6) 
  905          CONTINUE 
* 
  906              WRITE (LU,9975)
 9975              FORMAT(" If Source no. is >1000, error occurred" 
     *                    " in reading TUBE."/
     *                    "        Subtract 1000 to get source no.")
* 
  910          WRITE (LU,9980) NUMTRK 
 9980          FORMAT(//" Number of tracks performed:", I4) 
         WRITE (LU,9990) NSETS
 9990    FORMAT(/" Total number of sets of readings obtained:",I4)
* 
      WRITE (LU,9999) 
 9999 FORMAT(///"  *** END *** "///)
 1080 FORMAT(L6)
      END 
* 
********************************************************************* 
* 
*        SOURCE TRACKING SUBROUTINE - Now uses DRIVE as son program.
*             TRCK and  WAIT added as parameters. 
* 
********************************************************************* 
* 
$ALIAS/POINT/,NOALLOCATE
      SUBROUTINE TRACK (INTYPE, INLONG, INLAT, INTRACK, INWAIT) 
* 
      INTEGER INTYPE
      REAL    INLONG, INLAT 
      LOGICAL INTRACK, INWAIT 
* 
      INTEGER*2 TYPE, IBUF(7), DRIVE(3) 
      REAL*4    ALONG, ALAT 
      LOGICAL*2 TRCK, WAIT
* 
      EQUIVALENCE   (IBUF(1),TYPE),   (IBUF(2),ALONG),
     *              (IBUF(4),ALAT),   (IBUF(6),TRCK), 
     *              (IBUF(7),WAIT)
* 
      DATA    DRIVE /'DRIVE '/
* 
      TYPE = INTYPE 
      ALONG = INLONG
      ALAT = INLAT
      TRCK = INTRACK
      WAIT = INWAIT 
* 
*   Call DRIVE with the parameters as sepcified in the call 
* 
           CALL EXEC (9,DRIVE,0,0,0,0,0,IBUF,7) 
* 
      RETURN
      END 
* 
********************************************************************* 
* 
*       SUBROUTINE TO TRACK SOURCE, AND STAY ON TRACK FOR REQUIRED TIME 
*                 Uses subroutines TRACK, FLUX, WINFO 
* 
**********************************************************************
* 
      SUBROUTINE DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, NPRINT,
     *                  LU, NFRQ, TUFLUX, RESFIL, NAMRFL, 
     *                  SFLUX, SERR, DVM, CPLACE, NL) 
* 
         CHARACTER CPLACE(11)*2, NAMRFL*10
* 
         LOGICAL NEXT, PROB, HKEEP, FIRE, RPTFQ, WVTB, CALSRS, BADTRK 
* 
         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(11), SERR(11), DVM(11) 
* 
        COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE,
     *                    HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                    I, ITIME, IYEAR, RPTFQ, BADTRK, ERSORS, ERWAV,
     *                    KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
           NUMTRK = NUMTRK + 1
* 
*       Track position with pointing corrections and wait for STEER 
* 
         CALL TRACK (4, TRA, TDEC, .TRUE., .TRUE.)
* 
*       Turn on DVM's, fire noise tube and compute source FLUX and
*           RMS ERROR.
* 
        CALL FLUX (LU, TUFLUX, WAVE, NPRINT)
            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, BADTRK, k,*) 
* 
      CHARACTER NAMRFL*10, SEGNAM*5, CPLACE(11)*2, FCHAR*42 
* 
      LOGICAL   HKEEP, WVTB, RPTFQ, BADTRK
* 
      REAL      SFLUX(11), SERR(11), DVM(11)
* 
*       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, BADTRK, DVM(ILN)
  165    CONTINUE 
* 
 1100    FORMAT (L1, L1, A2, G12.6, G12.6, 2L1, 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, 'WRTFL', *900, k)  
          GO TO label 
* 
  900   RETURN k
      END 
* 
********************************************************************* 
* 
      BLOCK DATA
* 
********************************************************************* 
* 
       LOGICAL HKEEP, PROB, NEXT, FIRE, RPTFQ, BADTRK, 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, BADTRK, 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-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 CHANGE VALUES OF BEAM PARAMETERS.
* 
********************************************************************* 
* 
      SUBROUTINE PARAM (LU, WAVE, I, RAOFS, DEOFS, FNOFS, HPOFS,
     *                  BMSEP)
* 
         LOGICAL AOK
* 
         REAL    WAVE(1), RAOFS(1), DEOFS(1), FNOFS(1), HPOFS(1), 
     *           BMSEP(1) 
* 
  201    CONTINUE 
         WRITE (LU,2010) WAVE(I), RAOFS(I), DEOFS(I)
 2010    FORMAT(//3X," HA and DEC beam offsets for ",F5.1,"cm."/
     *           3X," system are: ",2F7.3," degrees "/
     *           /5X," OK (TRUE) or new values wanted (FALSE) ? _") 
         READ (LU,1080) AOK 
         IF ( AOK ) GO TO 202 
* 
            WRITE (LU,2020)  WAVE(I)
 2020       FORMAT(//3X," Enter new values for HA and DEC BEAM OFFSET "/
     *               3X," for the ",F5.1," cm. system: _")
            READ  (LU,*) RAOFS(I), DEOFS(I) 
           GO TO 201
* 
*       Check the values for the FIRST NULL points
* 
  202    CONTINUE 
* 
           WRITE (LU,2030) WAVE(I), FNOFS(I)
 2030      FORMAT(/3X," FIRST NULL offset for ",F5.1," cm." 
     *            /3X," system is: ",F7.3," degrees. ",/
     *            /6X," OK (TRUE) or new value wanted (FALSE) ? _") 
* 
           READ  (LU,1080) AOK
           IF ( AOK )      GO TO 230
           WRITE (LU,2040) WAVE(I)
 2040      FORMAT(/3X," Enter new value for FIRST NULL" 
     *                 " offset"/ 
     *             3X," for the ",F5.1," cm. system:_") 
* 
           READ  (LU,*) FNOFS(I)
* 
         GO TO 202
* 
*   Check the BEAM SEPARATION 
* 
  230  IF (BMSEP(I).EQ.0.) GO TO 900
  231  WRITE (LU,2070) WAVE(I), BMSEP(I)
 2070  FORMAT(/3X," BEAM SEPARATION of the ",F5.1," cm. " 
     *        /3X," system is: ",F7.3," degrees. "/ 
     *        /6X," OK (TRUE) or new value wanted (FALSE) ? _") 
* 
        READ (LU,1080) AOK
         IF ( AOK )   GO TO 900 
          WRITE (LU,2075) WAVE(I) 
 2075     FORMAT(/3X," Enter new values for BEAM SEPARATION "/
     *            3X," for the ",F5.1," cm. system : _")
* 
               READ (LU,*)  BMSEP(I)
            GO TO 231 
* 
 1080    FORMAT(L6) 
* 
  900  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, 'SUNTM', *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, NSKIP, CLSUN) 
* 
        LOGICAL CLSUN 
* 
        DATA  SUNLIM / 25. /
* 
         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.
         CLSUN = (ABS(RADIF) .LT. SUNLIM) .AND. 
     *           (ABS(DECDIF) .LT. SUNLIM)
         IF (CLSUN .AND. NSKIP.EQ.0)
     *      PRINT '(" too close to sun (RA and DEC ang. sep. resp.",
     *                 2F6.2,")_")', RADIF, DECDIF
        RETURN
      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(11)*2, NAMRFL*10
* 
       LOGICAL   HKEEP, PROB, RPTFQ, BADTRK, 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(11), SERR(11), DVM(11) 
* 
       COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, 
     *                  HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                  I, ITIME, IYEAR, RPTFQ, BADTRK, 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, F10.6, 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
 1200                FORMAT(L1, L1, F6.1, 2G12.6) 
* 
                 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, 'WINFO', *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
$ALIAS/POINT/,NOALLOCATE
* 
      SUBROUTINE FLUX (LU, TUFLUX, WAVE, NPRINT)
* 
         LOGICAL  NEXT, FTUBE, FIRE, HKEEP, PROB, RPTFQ, BADTRK, CALSRS 
* 
         INTEGER  IBUF(4),  HASL, SORSNM(5), IDCB(272), 
     *            ITIME(5), ERSORS(10), 
     *            LOGCLS, CMDCLS, CMDRSN
* 
         REAL     TUFLUX(1), JYDVM, WAVE(1), DIGVM(651), MEDTB, 
     *            MEDVAL, ERWAV(10), ERSQAV(10), PREVTB(4), TBNOM(4), 
     *            PREVER(4), MEDIAN,
     *            HALIM, DECLIM, HAERR, DECERR, REALHA, RELDEC
* 
      DOUBLE PRECISION TOTDVM, SUMSQ, SQDVM, AVDVM, SQAV, AVDSQ,
     *                 DIFF, STDEV
* 
      COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVAL, NEXT, FIRE, 
     *                    HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, 
     *                    I, ITIME, IYEAR, RPTFQ, BADTRK, ERSORS, ERWAV,
     *                    KERR, ERSQAV, CALSRS, IDCBS, TUBNET 
* 
         COMMON / POINT / LOGCLS, CMDCLS, CMDRSN, HALIM, DECLIM,
     *                    HAERR, DECERR, REALHA, RELDEC 
* 
         COMMON  /DOUT1/ ISERVO 
* 
         DATA   NSMPL / 650 /,  NTSAM / 650 /,  !Remember change DIGVM
     *          TBNOM / -.0564,   -.0123,   .0202,  .0520 / 
* 
           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
* 
*       Select DVM inputs, DIRECT, same freq on both. 
* 
  100     ISEL = (IFQ * 2 - 1) * 11B
          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.0D0 
                       SUMSQ = 0.0D0
* 
*       Loop to read DVM and average NSAM samples.
* 
           DO  200  NN = 1,NSAM 
* 
                READ (35,*) RDVM
* 
                ERRHA = HAERR 
                If (ABS(ERRHA) .GE. .010)  BADTRK = .TRUE.
* 
*      Keep running total of readings, arranging in order to calc median
* 
                   CALL MEDIN (LU, RDVM, NN, MEDIAN, DIGVM) 
* 
                        TOTDVM = TOTDVM + DBLE(RDVM)
                        SQDVM = DBLE(RDVM)*DBLE(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 = TOTDVM / COUNT
                     SQAV = SUMSQ/COUNT 
                     AVDSQ = AVDVM * AVDVM
* 
                   DIFF = SQAV - AVDSQ
                      If (DIFF .LT. 0.0D0) DIFF = 0.0D0 
                   STDEV = DSQRT( DIFF )
                   STDEV = STDEV/SQRT(COUNT2) 
* 
               If (FTUBE) then
                      TBDEV = SNGL(STDEV) 
                      MEDTB = MEDIAN
                 else 
                      VALDEV = SNGL(STDEV)
                      MEDVAL = MEDIAN 
               endif
* 
*        Check max value calculated, for 6 sig fig accuracy 
             If ( SQAV .GT. 8.388D07 )  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.0D0)  then
                         IF (IFAIL.EQ.0) then 
                            PRINT '(/,"_")' 
                            NPRINT = NPRINT+1 
                         endif
                         PRINT '(" DVM ZERO. Trying again._")' 
                         IFAIL = IFAIL + 1
* 
                         If (IFAIL .GT. 2) then 
                            PRINT '("Too many problems. Try next freq")'
                            NPRINT = NPRINT+1 
                            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 
                        IF ( IFQ .EQ. 1 ) IFREQ = 1          ! 3.6cm 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 MJG 1987 dec 21
                    TUBNET = MEDTB - MEDVAL       !Net tube in DVM units
* 
                    TLEVL = 4. * SNGL(STDEV) * SQRT(COUNT2) 
* 
                 If ( ABS(TUBNET) .LT. TLEVL )  then
                      PRINT '(/"Noise diode fired ( TUBNET ",G12.4,
     *                    " < TLEVL ",G12.4," ) ? _")',TUBNET,TLEVL 
                      NPRINT = NPRINT+1 
                      NTFAIL = NTFAIL + 1 
* 
*                     If no. errors is >2, use nominal/previous tube
*                                     value, and continue.
                             If (NTFAIL .GT. 2) 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 ",G10.4,"+-",G10.4,
     *                                   " DVM units")', TUBNET, TBDEV
                                 NPRINT = NPRINT+1
                             else 
                                 PRINT '("Trying again _")' 
                                 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 
  988      FIRE = .FALSE. 
      RETURN
      END 
* 
**********************************************************************
* 
*        SUBROUTINE TO CHOOSE OPERATING FREQS AND SET S REG BITS
* 
**********************************************************************
* 
       SUBROUTINE BITST 
* 
       PARAMETER (NWAVL=4)
* 
       CHARACTER  CHAR*1
* 
       LOGICAL AOK, DOFRQ(NWAVL)
* 
       INTEGER TIMSET(3), SWIN, ISETBT(NWAVL) 
* 
       REAL    WAVE(NWAVL), WAVUSE(NWAVL) 
* 
       DATA   WAVE  /  6.0,   3.6,   13.0,   18.0 /,
     *       ISETBT /  2B,    1B,    4B,     10B  / 
* 
  138      DO 139  L = 1,NWAVL
                 WAVUSE(L) = 0.0
                 DOFRQ(L) = .FALSE. 
  139      CONTINUE 
           PRINT '(/3X,"Wavelengths available :",/
     *             6X,4F7.1,"cm",/
     *             4X,"Enter which are to be used (/ to End) : _")',
     *              WAVE
* 
              READ *, (WAVUSE(L), L=1,NWAVL)
* 
*       Count the number of freqs used and check for incorrect input
* 
                  DO 141 L=1,NWAVL
                      IF ( WAVUSE(L) .EQ. 0.0 )  GO TO 142
* 
                      DO 140 LB=1,NWAVL 
                          IF (WAVUSE(L) .EQ. WAVE(LB)) then 
                             DOFRQ(LB) = .TRUE. 
                             GO TO 141
                          endif 
  140                 CONTINUE
                      PRINT '(/3X, F4.1, " is an incorrect wavelength.",
     *                        " Try again."/)', WAVUSE(L)
                       GO TO 138
  141             CONTINUE
* 
  142        KOUNT = L-1
             PRINT '(/3X,"Observing at",I3," wavelengths")',KOUNT 
* 
                 If (KOUNT .LE. 0)  then
                    PRINT '("INPUT ERROR")' 
                  GO TO 138 
                 endif
* 
  143     PRINT '(6X,"Wavelengths used :")' 
* 
                DO 144 L = 1,KOUNT
                    PRINT '(20X,F7.1)', WAVUSE(L) 
  144           CONTINUE
* 
           PRINT '(5X,"OK (T or F) ? _")' 
* 
               READ *, AOK
* 
            If ( .NOT. AOK ) GO TO 138
* 
*    Set S reg bits according to freqs to be used.
* 
  146    ISWIT = SWIN(0)
* 
          DO 147  LB = 1,NWAVL
            If (.NOT. DOFRQ(LB))  ISWIT = ISWIT .OR. ISETBT(LB) 
  147     CONTINUE
* 
*      Set reg
* 
  150        CALL SWOUT (ISWIT) 
* 
         RETURN 
         END
* 
**********************************************************************
*  Check hyperbola focus and tilt matches standards for this system  *
*   returns :                                                        *
*     FAULT       logical*2   false if focus & tilt within tolerance *
*                             otherwise set true                     *
**********************************************************************
* 
      SUBROUTINE CHKHYP (FAULT) 
* 
      REAL*4    STDFOCUS, STDTILT, SUBFOCUS, SUBTILT
      LOGICAL   FAULT 
      CHARACTER HYPMES*11, FOCMES*11, TILTMES*9, NOTMES*4 
* 
      DATA  TOLERANCE / 0.5 /, STDFOCUS / 7.5 /, STDTILT / -0.54 /, 
     &      HYPMES  /'HYPERBOLA '/,
     &      FOCMES  /'FOCUSED TO '/,
     &      TILTMES /'TILTED TO'/,
     &      NOTMES  /' NOT'/
* 
      FAULT = .FALSE. 
      CALL RHYP (SUBFOCUS, SUBTILT) 
      IF (ABS(SUBFOCUS-STDFOCUS) .GT. TOLERANCE) THEN 
          FAULT = .TRUE.
          PRINT *,HYPMES//FOCMES,SUBFOCUS,NOTMES,STDFOCUS 
      END IF
      IF (ABS(SUBTILT-STDTILT) .GT. TOLERANCE) THEN 
          FAULT = .TRUE.
          PRINT *,HYPMES//TILTMES,SUBTILT,NOTMES,STDTILT
      END IF
* 
      RETURN
      END 
* 
******************************************************************* 
*                                                                 * 
*     Scheduling subroutines for use with SCHDL                   * 
*                                                                 * 
      include &SSBQS::16           !                              * 
*                                                                 * 
*     Antenna limit function as in STEER   MJG 1987 dec 9         * 
*                                                                 * 
      include &HALIM::16           !                              * 
*                                                                 * 
*     Computer fail observing alarm                               * 
*                                                                 * 
      include &OBSOK::16           !                              * 
*                                                                 * 
*     Hyperbola tilt and focus readout through DVM                * 
*                                                                 * 
      include &RHYP::16            !                              * 
*                                                                 * 
******************************************************************* 
