FTN77,S 
$FILES 0,2
      PROGRAM TNSTP (3,80)
*************************** 
* 
*     PROGRAM TO STEP AROUND ALL BEAMS IN DEC AND RA
*     to compile: 
*         FTN7X &TNSTP::16 0 -
*     to load:
*         LOADR:IH
*             OP,RPEBSS 
*             FM,DC 
*             RE,%TNSTP::16 
*             EN
* 
*     WRITTEN BY DCB 1982/04/30 
*     COPY OF TONOF AT 1984/09/27  D271 
*     Added 40 mdeg to all RAOFS  on 1985/08/01  D213 
*     New feed positions 1985/08/07.  Changed RAOFS DEOFS D 232 
*     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 
*     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, day 141 
*     Changed TUFLUX at 18 cm from 140 JY per DVM  unit to 403 1992D336 
*     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
*     output "end of source file return to No.1" commented out 19/10/95 MG
*     last revised <990510.1213>
********************************************************************* 
* 
      CHARACTER CPLACE(21)*2, NAMRFL*10 
* 
      LOGICAL AOK, START, CHK, HKEEP, PROB, NEXT, FIRE, 
     *        RPTFQ, DUALBM, WVTB, CALSRS, IFBRK, NO3P4,
     *        BELOW, FIRST
* 
      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), 
     *        timeon(5) 
* 
      REAL    FNOFS(5), HPOFS(5), 
     *        RAOFS(5), DEOFS(5), WAVE(5), TUFLUX(5), 
     *        BMSEP(5), ERWAV(10), ERSQAV(10), MEDTB, MEDVM,
     *        SFLUX(21), SERR(21), DVM(21)
* 
      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) 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 BSday. 
* 
*        HALIM is the Hour Angle limit for acceptable data
* 
      DATA WAVE  /  6.2,     3.4,      13.0,    18.0,     6.1    /, 
     *     FNOFS /  0.18,    0.115,    0.393,    0.559,   0.18   /, 
     *     HPOFS /  0.082,   0.048,    0.166,    0.232,   0.082  /, 
     *     RAOFS /  0.011,   0.110,    0.051,    0.074,   0.011  /, 
     *     DEOFS / -0.251,  -0.588,    0.426,    0.904,  -0.251  /, 
     *     BMSEP /  0.254,   0.254,    0.0,      0.0,     0.0    /, 
     *     TUFLUX/  24.0,    175.0,    35.0,   403.0,     200.0  /, 
     *     NFRQ / 5 /,
     *     ISIZE / 5 /,  ITYPE /  3 /, ISECU / 0 /, ICR / 15 /, 
     *     RESFIL / 2HBS, 2H00, 2H   /, 
     *     HALIM  / 5.4 /,
     *     CHK / .FALSE. /, LU / 7 /, 
     *     DPRC2 / 2HDP, 2HRC, 2H2  / 
* 
*        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 (TNSTP) : DAY ",I3,",",I4/ 
     *         3X,38"="// 
     *         3X,"THIS VERSION STEPS AROUND ALL BEAMS",//
     *         3X," Source file must use 1950.0 coordinates. ", 
     *       //3X," Set S register bit 0 ON to suspend 3.4 cm readings" 
     *        /22X," 1 ON to suspend 6.2 cm readings, ie DUAL FEEDS"
     *        /22X," 2 ON to suspend 13.0cm readings" 
     *        /22X," 3 ON to suspend 18.0cm readings" 
     *        /22X," 4 ON to suspend 6.1 cm readings, ie SINGLE FEED" 
     *       //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." /)
* 
         CALL BITST         !Choose operating freqs,set S-reg 
         CALL RNALC(IRN)    ! Allow scheduling   ** inserted by CF 5/88 
* 
*        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. 
* 
*     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 140
* 
*      CHECK THE BEAM PARAMETERS FOR EACH FREQUENCY 
*      -------------------------------------------- 
      DO 130 I=1,NFRQ 
* 
*        Bits 0,1,2,3,4  set for skip 3.4,6.2,13.0,18.0,6.1 cm. measurements
               ISWIT = SWIN(0)
               ISWIT = ISWIT .AND. 000037B
                  GO TO (132, 131, 133, 134, 135) I 
* 
  131              ISWIT = ISWIT .AND. 1B 
                   IF ( ISWIT .EQ. 1B )  GO TO 130
                       GO TO 139
  132                ISWIT = ISWIT .AND. 3B 
                     IF ( ISWIT .GE. 2B )  GO TO 130
                       GO TO 139
  133                ISWIT = ISWIT .AND. 7B 
                     IF ( ISWIT .GE. 4B )  GO TO 130
                       GO TO 139
  134                ISWIT = ISWIT .AND. 17B
                     IF ( ISWIT .GE. 10B)  GO TO 130
                       GO TO 139
  135                ISWIT = ISWIT .AND. 37B
                     IF ( ISWIT .GE. 20B)  GO TO 130
* 
  139    CALL PARAM (LU, WAVE, I, RAOFS, DEOFS, FNOFS, HPOFS, 
     *               BMSEP) 
  130 CONTINUE
* 
  140   CONTINUE
*       FIND THE SOURCE FILE DATA AND CHECK IT
* 
  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 
* 
*         Confirm that this is correct
* 
      WRITE (LU,3150)  (FILNAM(J), J=1,3), NFIRST 
 3150   FORMAT(/3X," Using source file ",3A2,/
     *          3X," and 1950.0 coordinates. ",/
     *          3X," Starting at source ",I4,// 
     *          6X," OK? (TRUE or FALSE) :_") 
          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
        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.
*                   If file is for 1144-37 measurements then smaller
  820    IF (FILNAM(2) .EQ. 12593) ISIZE = 20 
         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)
* 
        PRINT'(//3X,"SOURCE",4X,"HA",3X,"WAVE",4X,"START",5X,"BEAM/", 
     *          29X,"FLUX +- ERROR",40X,"NOISE")' 
        PRINT '("No.   Name",2X,"(hr)",2X,"(cm)",2X,"TIME (UT)",
     *          3X,"SCAN","_")' 
        PRINT '(4X,"FN",12X,"HP",12X,"ON",12X,"HP",12X,"FN",12X,"CE", 
     *           4X,"DIODE (DVM)")' 
* 
             PRINT '(131"=")' 
* 
*     Read the parameters of 1 source. Close the file after reading.
* 
*  START OF LOOP FOR EACH SOURCE. 
* 
  500   CONTINUE
* 
* Allow SCHDL to interrupt  
          CALL RNCLW(IRN) 
* 
*                Check if BIT 15 has been set 
* 
           IF(ISSW(15) .LT. 0)     GO TO 900
       NREC = NREC + 1
* 
*            Program suspends here if bit 13 set or BREAK 
                 IF ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) )  GO TO 512 
* 
*                   Read S reg, reset bit 13, clear reg and pause.
                         ISWIT = SWIN(0)
                         ISWIT = ISWIT .AND. 157777B
                         CALL ISSR(0) 
                   WRITE (LU,5010)
 5010              FORMAT(/" TNSTP SUSPENDED - GO,TNSTP to restart"///) 
* 
           REG = 0.0
           REG = EXEC(7)
* 
*         GO,TNSTP,NSKIP  NSKIP  is the no. of sources to skip on restart 
*               If NSKIP omitted, program restarts at point of suspension 
*                    B register >0 if parameter follows GO command. 
* 
               IF ( IAB(2) )   510, 510, 505
* 
  505              CALL RMPAR (IPRAM) 
                         NREC = NREC + IPRAM(1) 
* 
*           On restart..... 
* 
  510          CALL ISSR(0) 
               CALL SWOUT(ISWIT)
* 
                  CALL EXEC (11,ITIME,IYEAR)
                  PRINT '(//"Restarted at ",2I5," Day",2I5)',(ITIME(LT),
     *                                   LT = 4,3,-1), ITIME(5), IYEAR
* 
*              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 
* 
*     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 ") 
         GO TO 320
* 
  535  IF( LEN .GT. 0)  GO TO 540 
* 
ccccccccccccc comment out to save paper MJG 1995 10 19
c            WRITE (LU,5130)
c5130         FORMAT (" END OF SOURCE FILE. RETURN TO No. 1"//) 
* 
           NREC = 0 
         GO TO 500
* 
*      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)
* 
*       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 
* 
*         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, sorsnm,
     *                 *500, 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 
* 
c        WRITE (LU,5900) ISTH, ISTM, ISTS 
c5900    FORMAT(//2X," Siderial time: HH MM SS: ",/17X,3I3) 
* 
*          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") 
                       NJUMPS = NJUMPS + 1
                       If (NJUMPS .GE. 70) then 
* 
                           PRINT '("Too many jumps. Wait 30 min")'
                           CALL EXEC (12, 0, 3, 0, -30) 
                           NREC = NREC - NJUMPS 
                              IF (NREC .LT. 0)  NREC = 0
                           NJUMPS = 0 
                       endif
                     GO TO 500
                 else 
                     NJUMPS = 0 
                 endif
* 
*   Print source file information and headers for each track. 
* 
c 600 WRITE (LU,6000) 
c6000 FORMAT(/1X," NO.  SOURCE     RA         DEC  Cal? 3.4? ") 
c       WRITE (LU,6100) 
c6100   FORMAT(1X,"_")
c         CALL EXEC (2,LU,SORSBF,LEN) 
* 
            write (lu,6250) nsors, (sorsnm(l), l=2,5), ha 
 6250        format (i3,1x,4a2,1x,f3.1,"_") 
            FIRST = .TRUE.
* 
*         Print HEADERS for each track
* 
c      WRITE (LU,6200)
c6200  FORMAT(//8X,"  FREQ     PLACE        START TRACK AT",12X,"FLUX"/ 
c    *          8X," USED(cm) TRACKED   RA",7X,"DEC",6X,"TIME",8X,"(Jy)"
c    *         /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 
* 
*       Skip 3.4 cm meas on designated sources
* 
           IF ( NO3P4 .AND. WAVE(I) .EQ. 3.4 )  GO TO 700 
* 
*        Bits 0,1,2,3,4  set for skip 3.4,6.2,13.0,18.0,6.1 cm. measurements
               ISWIT = SWIN(0)
               ISWIT = ISWIT .AND. 000037B
                  GO TO (702, 701, 703, 704, 705) 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
* 
  711      DUALBM = ((WAVE(I) .EQ. 3.4) .OR. (WAVE(I) .EQ. 6.2))
* 
            if (FIRST) then 
               FIRST = .FALSE.
               write (lu,7100) wave(i)
 7100          format(2x, f4.1,3x,"_")
            else
               write (lu,7150) wave(i)
 7150          format(16x, 2x, f4.1,3x,"_") 
            endif 
* 
*       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) 
* 
          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 
* 
              call exec (11,timeon) 
           write (lu,7200) timeon(4),timeon(3),timeon(2)
 7200      format(3(i2,1x),"_") 
* 
         DO 720 LBM = 1, 2
* 
           IF (.NOT. DUALBM .AND. LBM .GE. 2)  GO TO 720
* 
            if (lbm .eq. 1) then
               write (lu,7250)  
 7250          format (1x,"A","_")  
            else
               print '(/,31x,4x,"B","_")'   
            endif 
* 
            print '("Dec _")' 
* 
             SEPFAC = -1. * SEPFAC
* 
*         TRACKING AT FIRST NULL. 
*          Calculate coordinates: 
* 
        TRA = ONRA - SEPFAC 
        TDEC= ONDEC + FNOFS(I)
        KPLACE = 2HFN 
* 
        IF (LBM .EQ. 1) FIRE = .TRUE. 
        IF (LBM .EQ. 1) 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, NAMRFL,  
     *             SFLUX, SERR, DVM, CPLACE, NL)
         IF ( NEXT )  GO TO 700 
         IF ( PROB )  GO TO 900 
* 
*     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, 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, 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, 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, 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 
* 
               print '(/,37x,"RA _")' 
* 
                 TRA = ONRA - SEPFAC - FNOFS(I)/CORDEC
                 TDEC = ONDEC 
                 KPLACE = 2HFN
* 
          CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE,
     *                LU, NFRQ, TUFLUX, RESFIL, 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, 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, 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, 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, NAMRFL, 
     *                SFLUX, SERR, DVM, CPLACE, NL) 
           IF ( NEXT )  GO TO 700 
           IF ( PROB )  GO TO 900 
* 
*       For dual beam systems, take meas at centre
* 
          If (DUALBM .AND. LBM .EQ. 1) then 
* 
             TRA = ONRA 
             TDEC = ONDEC 
             KPLACE = 2HCE
* 
         CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, 
     *               LU, NFRQ, TUFLUX, RESFIL, NAMRFL,  
     *               SFLUX, SERR, DVM, CPLACE, NL)
            IF (NEXT)  GO TO 700
            IF (PROB)  GO TO 900
          endif 
* 
  720    CONTINUE 
* 
*    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
c        PRINT '("Noise tube ",F12.4," DVM units.", 
c    *           " Assuming tube equivalent flux ",F8.2," Jy")',
c    *    TUBNET, tuflux(i) 
* 
           print '(12x,f10.4)', tubnet
* 
*    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
* 
          print '(/)' 
* 
*      Go back to run for next source.
      GO TO 500 
  900 CONTINUE
* 
         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 a son program
*            TRCK and WAIT added as new parameters. 
* 
********************************************************************* 
* 
      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, 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, NAMRFL, 
     *                  SFLUX, SERR, DVM, CPLACE, NL) 
* 
         CHARACTER CPLACE(21)*2, NAMRFL*10
* 
         LOGICAL NEXT, PROB, HKEEP, FIRE, RPTFQ, 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(21), SERR(21), DVM(21) 
* 
        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
* 
c      WRITE (LU,1000) WAVE(I), KPLACE, TRA, TDEC 
c1000  FORMAT(9X, F5.1, 6X, 1A2, 4X, F7.3, 2X, F7.3,"_")
* 
         CALL TRACK (4, TRA, TDEC, .TRUE., .TRUE.)
* 
c         CALL EXEC (11,TIMON)
c            WRITE (LU,1100) TIMON(4), TIMON(3), TIMON(2) 
c1100        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(21)*2, FCHAR*42 
* 
      LOGICAL   HKEEP, WVTB, RPTFQ
* 
      REAL      SFLUX(21), SERR(21), DVM(21)
* 
*       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 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 203
           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 values for the HALF POWER points are correct
* 
  203      CONTINUE 
           WRITE (LU,2050) WAVE(I), HPOFS(I)
 2050      FORMAT(/3X," HALF POWER 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 231
* 
           WRITE (LU,2060) WAVE(I)
 2060      FORMAT(/3X," Enter new value for HALF" 
     *                " POWER offset ",/
     *             3X," for the ",F5.1," cm. system:_") 
* 
           READ  (LU,*) HPOFS(I)
         GO TO 203
* 
*   Check the BEAM SEPARATION 
* 
  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 values 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, '     ', *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, sorsnm, 
     *                     ksun,*)
* 
            integer sorsnm(5) 
* 
            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 ",I4,2x,5a2," too close to sun"/
     *                  "RA and DEC angular separation from sun resp.", 
     *                   2(2X,F6.2),/ 
     *                  "Source skipped")', NSORS, (sorsnm(l),l=1,5), 
     *                  RADIF, DECDIF 
* 
                 ksun = 1 
          endif 
* 
        RETURN ksun 
        END 
* 
********************************************************************* 
* 
*         Subroutine for suspending observing program.
* 
*           NREC is the parameter that can be modified with the GO
*            command; eg. to skip sources GO,PROGNM,NSKIP where NSKIP 
*            is added to NREC on restart. 
* 
********************************************************************* 
* 
       SUBROUTINE SSPND (NREC, PRGNAM, PSUSPD)
* 
       CHARACTER  PRGNAM*5
* 
       LOGICAL    PSUSPD, IFBRK 
* 
       INTEGER    SWIN, IAB(2), IPRAM(5), ITIME(5)
* 
       EQUIVALENCE (REG,IAB(1)) 
* 
       DATA       SSLIMT / 5. / 
* 
            PSUSPD = .FALSE.
* 
*      Program suspends if S register bit 13 set ON or break flag has 
*        been set by typing *BR,PRGNAM, else continue 
* 
        If ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) )  GO TO 900
* 
*      Read S-register to preserve reading, reset bit 13
          ISWIT = SWIN(0) 
          ISWIT = ISWIT .AND. 157777B 
          CALL ISSR(0)
* 
             CALL EXEC (11, ITIME,IYEAR)
             UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +  !MINUTES
     *               FLOAT(ITIME(2))/60.
* 
              PRINT '(/, A5," SUSPENDED.  GO,",A5,",NSKIP to restart"/, 
     *                 4X,"NSKIP (+ or -) is optional.",
     *                    " Use to skip sources on restart")',
     *                       PRGNAM, PRGNAM 
* 
         REG = 0.0
         REG = EXEC(7)
* 
*         GO,PRGNAM,NSKIP  NSKIP is the no. sources to skip on restart
*            If NSKIP is omitted, program restarts at point of suspension 
*                B register >0 if parameter follows GO command
* 
* 
          If (IAB(2))  510, 510, 505
* 
  505      CALL RMPAR(IPRAM)
                NREC = NREC + IPRAM(1)
* 
*          On restart.....
* 
  510      CALL ISSR(0) 
*            Check length of time the program was suspended 
             CALL EXEC (11, ITIME, IYEAR) 
             UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +    !MINUTES
     *               FLOAT(ITIME(2))/60.
             SUSTIM = UTAFT - UTBEF 
                   If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440.
              If (SUSTIM .GT. SSLIMT)  then 
                  PRINT '(A1)', CHAR(14B)                     !Form feed
                  PRINT '("Restarted at",2I5,"Day ",2I5)', (ITIME(L), 
     *                                  L=4,3,-1), ITIME(5), IYEAR
                  PSUSPD = .TRUE. 
              endif 
* 
*        Replace S-reg value from before suspension 
           CALL SWOUT (ISWIT) 
* 
  900    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(21)*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(21), SERR(21), DVM(21) 
* 
       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(3), TBNOM(3), 
     *            PREVER(3), 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 / 
* 
           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 = 2
* 
*       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.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 
                        if ( i .eq. 5) ifreq = 2          ! 6.1cm tube
                        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 
c           PRINT '(F6.3,"+-",F5.3)', SORSJY, ERROR 
* 
           print '(f6.2,1x,f5.3,1x,"_")', sorsjy, error 
* 
  988      FIRE = .FALSE. 
      RETURN
      END 
* 
**********************************************************************
* 
*        SUBROUTINE TO CHOOSE OPERATING FREQS AND SET S REG BITS
* 
**********************************************************************
* 
       SUBROUTINE BITST 
* 
       PARAMETER (NWAVL=5)
* 
       CHARACTER  CHAR*1
* 
       LOGICAL AOK, DOFRQ(NWAVL)
* 
       INTEGER TIMSET(3), SWIN, ISETBT(NWAVL) 
* 
       REAL    WAVE(NWAVL), WAVUSE(NWAVL) 
* 
       DATA    WAVE / 6.2,   3.4,   13.0,   18.0,   6.1 /,
     *        ISETBT/  2B,    1B,    4B,    10B,    20B / 
* 
  140      PRINT '(/3X,"Wavelengths available :",/
     *             6X,5F7.1,"cm",/
     *             4X,"Enter which are to be used (in cm.) :_")', 
     *              WAVE
* 
              READ *, (WAVUSE(L), L=1,NWAVL)
* 
                  DO 141 L=1,NWAVL+1
                          DO 138 LN = 1,NWAVL 
                              If (WAVUSE(L) .EQ. WAVE(LN)) GO TO 139
  138                     CONTINUE
                          If (WAVUSE(L) .NE. 0.0) then
                          PRINT '(/3X,"No match for wavelength",F5.1, 
     *                           4X,"Check available list")', WAVUSE(L) 
                            DO 137 LN = 1,NWAVL 
                                   WAVUSE(LN) = 0.
  137                       CONTINUE
                          GO TO 140 
                          endif 
  139                 KOUNT = L-1 
                      IF ( WAVUSE(L) .EQ. 0.0 )  GO TO 142
  141             CONTINUE
* 
  142        PRINT '(/3X,"Observing at",I3," wavelengths")',KOUNT 
* 
                 If (KOUNT .LE. 0)  then
                    PRINT '("INPUT ERROR")' 
                  GO TO 140 
                 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 )  then
                   DO 145  L = 1,KOUNT
                         WAVUSE(L) = 0.0
  145              CONTINUE 
                 GO TO 140
            endif 
* 
*    Set S reg bits according to freqs to be used.
* 
  146    ISWIT = SWIN(0)
* 
         DO 200 LB = 1,NWAVL
             DO 210 LBB = 1,NWAVL 
                    DOFRQ(LB) = (WAVUSE(LBB) .EQ. WAVE(LB)) 
                    If (DOFRQ(LB)) GO TO 200
  210        CONTINUE 
  200   CONTINUE
* 
          DO 250  LB = 1,NWAVL
            If (.NOT. DOFRQ(LB))  ISWIT = ISWIT .OR. ISETBT(LB) 
  250     CONTINUE
* 
*      Set reg
* 
  150        CALL SWOUT (ISWIT) 
* 
         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  <990510.1213>
* 
********************************************************************* 
* 
*        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
* 
********************************************************************* 
* 
*         Subroutine to allocate and set RN, write observing info to
*            disc file
* 
********************************************************************* 
$ALIAS RNRQ, NOABORT
* 
        SUBROUTINE RNALC (IRN)
* 
        PARAMETER (MAXPRG = 10) 
* 
        CHARACTER  DATNAM*10, PRGNAM*6, DUMCHR*1, OBPCHR*108, 
     *             SHPCHR(MAXPRG)*108, OBPNM*6, SEGNAM*5  
* 
        LOGICAL    OB3P4, OB6CM, OB13CM, OB18CM, ob2p5, ob4p5,
     *             DUAL34, DUAL6, NADD13, NADD18, NOALC, nadd25, nadd45 
* 
        DATA       NOBORT / 40000B /, DATNAM /'SHDATA::16'/,
     *             PRGNAM /'TNSTP'/,
     *             OB3P4 /.TRUE./, OB6CM /.TRUE./, OB13CM /.TRUE./, 
     *             OB18CM /.FALSE./,
     *             ob2p5 / .false. /, ob4p5 / .false. /,
     *             DUAL34/.TRUE./, DUAL6 /.TRUE./, NADD13 /.TRUE./, 
     *             NADD18 /.FALSE./,
     *             nadd25 / .false. / , nadd45 / .false. /
* 
                   SEGNAM = 'RNALC' 
* 
*        Open, read and close file containing SCHEDULING parameters 
* 
                 Assign 110 to label
                   NSTMT = 110
  110       OPEN (10, file=DATNAM, iostat=ierr, err=820, status='OLD')
* 
*             Read file to preserve existing parms from other progs 
                 Assign 115 to label
                    NSTMT = 115 
  115        READ (10,'(A108)', iostat=ierr, err=820) OBPCHR  
*                        NPROGS is the no of programs in schedule 
                READ (OBPCHR(1:14),'(I2,A6,I6)', iostat=ierr, err=820)
     *                                  NPROGS, OBPNM, LLRN 
             READ (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), 
     *                                             K = 1,NPROGS)
             REWIND 10              ! Get to BOF for writing
* 
               If (OBPNM .EQ. PRGNAM) then
                     NOALC = .FALSE.
                     GO TO 118
               endif
* 
        PRINT '(3X,"Is this program running while ",A6," suspended ?"/
     *          9X,"Yes (T) _")', OBPNM 
           READ *, NOALC
* 
*         If this prog runs during suspension of a prog that has already
*            allocated a RN, use this no.- don't allocate another 
* 
  118     If ( NOALC )  then
                       ICON = 1B + NOBORT                  ! Local set
                     CALL RNRQ (ICON, LLRN, ISTAT, *850)
                        IRN = LLRN
                         PRINT '("Local set RN ",I4)', IRN
          else
* 
*              Global allocate and local set RN 
* 
                       ICON = 21B + NOBORT
                     CALL RNRQ (ICON, IRN, ISTAT, *850) 
C              PRINT '("TNSTP global allocate, local set RN ",I4)', IRN 
* 
*                 Write allocated RN to file ALCRNS as record 
                       CALL RNFIL (IRN, *900, k)
          endif 
* 
*        Write info on this program to disc file, replacing other info
* 
                 Assign 120 to label
                    NSTMT = 120 
  120       WRITE (10, 1200, iostat=ierr, err=820) NPROGS, PRGNAM,
     *                IRN, OB3P4, OB6CM, OB13CM, OB18CM,
     *                ob2p5, ob4p5, 
     *                DUAL34, DUAL6, NADD13, NADD18,
     *                nadd25, nadd45
            WRITE (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), 
     *                                             K = 1,NPROGS)
* 
                     Assign 160 to label
                         NSTMT = 160
  160              CLOSE (10, iostat=ierr, err=820) 
* 
         GO TO 900
* 
*      Error handling 
* 
* 
  820   If (ierr .eq. 462) then 
              PRINT '("Disc file ",(A10)," does not exist."/, 
     *                "Run SHPRM on other terminal to create it."/
     *                "Hit RETURN when done.",
     *                " _")', DATNAM
              READ '(A1)', DUMCHR 
           GO TO 110
        else
* 
          Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) 
          GO TO label 
        endif 
* 
*        RN errors
  850       PRINT '("Error in RNALC for ICON, IRN, ISTAT = ",K6,2I5)',
     *                         ICON, IRN, ISTAT 
* 
  900   RETURN
* 
 1200    FORMAT (I2, A6, I6, 12L2, 70X) 
      END 
* 
********************************************************************* 
* 
*       SUBROUTINE TO WRITE ALLOCATED RN's TO FILE
* 
********************************************************************* 
* 
       SUBROUTINE RNFIL (IRN, k,*)
* 
      CHARACTER NAMFIN*10, SEGNAM*5 
* 
      DATA   NAMFIN / 'ALCRNS::16' /
* 
             SEGNAM = 'RNFIL' 
* 
*       File operations 
* 
*    Open file,if it exists 
* 
       Assign 110 to label
         NSTMT=110
  110  OPEN (20, file=NAMFIN, iostat=ierr, err=810, status='OLD') 
* 
*         Find EOF
       Assign 120 to label
         NSTMT=120
  120  DO WHILE (ierr .ne. -1)
          READ (20, 1100, iostat=ierr, err=820, end=150) IRNFIL 
        end do
        Assign 150 to label 
           NSTMT=150
  150   BACKSPACE(20, iostat=ierr, err=820) 
* 
*          Write info to file 
* 
         Assign 160 to label
          NSTMT=160 
  160    WRITE (20, 1100, iostat=ierr, err=820)  IRN
* 
*         Write EOF 
          Assign 170 to label 
              NSTMT=170 
  170     ENDFILE (20, iostat=ierr, err=820)
* 
              Assign 180 to label 
                   NSTMT=180
  180         CLOSE (20, iostat=ierr, err=820)
* 
       GO TO 900
* 
*      Error handling 
* 
*         Check if error due to file not existing.
* 
  810   If (ierr .eq. 462) then 
          PRINT '("Creating file ",(A10)," for list of allocated RN")', 
     *                                                NAMFIN
           OPEN (20, file=NAMFIN, iostat=ierr, err=820, status='NEW') 
* 
            GO TO 120 
         endif
* 
*     General error checking. 
* 
  820     Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) 
          GO TO label 
* 
 1100    FORMAT (I6)
* 
  900   RETURN k
      END 
* 
********************************************************************* 
* 
*         Subroutine for end of observing program cycle.
*               Clears, waits, sets RN to allow break-in of daily prog. 
* 
********************************************************************* 
* 
$ALIAS RNRQ, NOABORT
* 
       SUBROUTINE RNCLW (IRN, PSUSPD) 
* 
       LOGICAL    PSUSPD
* 
       INTEGER    SWIN, ITIME(5)
* 
       DATA       NOBORT / 40000B /,
     *            SSLIMT / 1. /          !Limit IN MINUTES after which
*                           program assumes interruption was significant
          PSUSPD = .FALSE.
* 
*      Read S-register to preserve reading
          ISWIT = SWIN(0) 
* 
*      Clear RN 
             CALL EXEC (11, ITIME, IYEAR) 
             UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +  !MINUTES
     *               FLOAT(ITIME(2))/60.
* 
            ICON = 4B + NOBORT
         CALL RNRQ (ICON, IRN, ISTAT, *850) 
C        PRINT '("TNSTP clears RN ",I4)', IRN 
* 
*           Wait 3 sec so scheduling prog can cut in if waiting 
          CALL EXEC (12, 0, 2, 0, -3) 
* 
*       Request local set 
            ICON = 1B + NOBORT
           CALL RNRQ (ICON, IRN, ISTAT, *850) 
C          PRINT '("TNSTP locally sets RN ",I4)', IRN 
* 
*            Check length of time the program was suspended 
             CALL EXEC (11, ITIME, IYEAR) 
             UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +    !MINUTES
     *               FLOAT(ITIME(2))/60.
             SUSTIM = UTAFT - UTBEF 
                   If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440.
              If (SUSTIM .GT. SSLIMT)  then 
                  PRINT '(A1)', CHAR(14B)                     !Form feed
                  PRINT '("Restarted at",2I5," Day",2I5)', (ITIME(L), 
     *                                  L=4,3,-1), ITIME(5), IYEAR
                  PSUSPD = .TRUE. 
              endif 
* 
*        Replace S-reg value from before suspension 
           CALL SWOUT (ISWIT) 
* 
         GO TO 900
* 
*     Error point 
  850    PRINT '("Error in RNCLW for ICON, IRN, ISTAT = ", K6, 2I5)', 
     *                                          ICON, IRN, ISTAT
* 
  900    RETURN 
        END 
* 
********************************************************************* 
* 
*         Subroutine for suspending observing program.
*               Clears RN, suspends obs prog till GO command, sets RN.
* 
*           NREC is the parameter that can be modified with the GO
*            command; eg. to skip sources GO,PROGNM,NSKIP where NSKIP 
*            is added to NREC on restart. 
* 
********************************************************************* 
* 
$ALIAS RNRQ, NOABORT
* 
       SUBROUTINE SUSPD (IRN, NREC, PSUSPD) 
* 
       LOGICAL    PSUSPD, IFBRK 
* 
       INTEGER    SWIN, IAB(2), IPRAM(5), ITIME(5)
* 
       EQUIVALENCE (REG,IAB(1)) 
* 
       DATA       NOBORT / 40000B /, SSLIMT / 5. /
* 
            PSUSPD = .FALSE.
* 
*      Program suspends if S register bit 13 set ON or break flag has 
*        been set by typing *BR,PRGNAM, else continue 
* 
        If ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) )  GO TO 900
* 
*      Read S-register to preserve reading, reset bit 13
          ISWIT = SWIN(0) 
          ISWIT = ISWIT .AND. 157777B 
          CALL ISSR(0)
* 
*      Clear RN 
             CALL EXEC (11, ITIME,IYEAR)
             UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +  !MINUTES
     *               FLOAT(ITIME(2))/60.
            ICON = 4B + NOBORT
         CALL RNRQ (ICON, IRN, ISTAT, *850) 
C        PRINT '("TNSTP clears RN ",I4)', IRN 
* 
         PRINT '(/"TNSTP SUSPENDED.  GO,TNSTP,NSKIP to restart"/, 
     * 4X,"NSKIP (+ or -) is optional. Use to skip sources on restart")'
* 
         REG = 0.0
         REG = EXEC(7)
* 
*         GO,TNSTP,NSKIP  NSKIP is the no. sources to skip on restart 
*            If NSKIP is omitted, program restarts at point of suspension 
*                B register >0 if parameter follows GO command
* 
* 
          If (IAB(2))  510, 510, 505
* 
  505      CALL RMPAR(IPRAM)
                NREC = NREC + IPRAM(1)
* 
*          On restart.....
* 
  510      CALL ISSR(0) 
*            Check length of time the program was suspended 
             CALL EXEC (11, ITIME, IYEAR) 
             UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) +    !MINUTES
     *               FLOAT(ITIME(2))/60.
             SUSTIM = UTAFT - UTBEF 
                   If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440.
              If (SUSTIM .GT. SSLIMT)  then 
                  PRINT '(A1)', CHAR(14B)                     !Form feed
                  PRINT '("Restarted at",2I5,"Day ",2I5)', (ITIME(L), 
     *                                  L=4,3,-1), ITIME(5), IYEAR
                  PSUSPD = .TRUE. 
              endif 
* 
*        Check if program which interrupted this one changed parameters 
*             in SHDATA and replace with values for this program if nec.
* 
            CALL CHFIL (IRN)
* 
*       Local set 
            ICON = 1B + NOBORT
           CALL RNRQ (ICON, IRN, ISTAT, *850) 
C          PRINT '("TNSTP locally sets RN ",I4)', IRN 
* 
*        Replace S-reg value from before suspension 
           CALL SWOUT (ISWIT) 
* 
         GO TO 900
* 
*     Error point 
  850    PRINT '("Error in SUSPD for ICON, IRN, ISTAT = ", K6, 2I5)', 
     *                               ICON, IRN, ISTAT 
* 
  900    RETURN 
        END 
* 
********************************************************************* 
* 
*         Subroutine change values on SHDATA if these were overwritten
*            during suspension
* 
********************************************************************* 
* 
$ALIAS RNRQ, NOABORT
* 
        SUBROUTINE CHFIL (IRN)
* 
        PARAMETER (MAXPRG = 10) 
* 
        CHARACTER  DATNAM*10, PRGNAM*6, DUMCHR*1, OBPCHR*108, 
     *             SHPCHR(MAXPRG)*108, OBPNM*6, SEGNAM*5  
* 
        LOGICAL    OB3P4, OB6CM, OB13CM, OB18CM, ob2p5, ob4p5,
     *             DUAL34, DUAL6, NADD13, NADD18, NOALC, nadd25, nadd45 
* 
        DATA       NOBORT / 40000B /, DATNAM /'SHDATA::16'/,
     *             PRGNAM /'TNSTP'/,
     *             OB3P4 /.TRUE./, OB6CM /.TRUE./, OB13CM /.TRUE./, 
     *             OB18CM /.FALSE./,
     *             ob2p5 / .FALSE. / , ob4p5 / .FALSE. /, 
     *             DUAL34/.TRUE./, DUAL6 /.TRUE./, NADD13 /.TRUE./, 
     *             NADD18/.FALSE./, 
     *             nadd25 / .false. / , nadd45  / .false. / 
* 
                   SEGNAM = 'CHFIL' 
* 
*        Open, read and close file containing SCHEDULING parameters 
* 
                 Assign 110 to label
                   NSTMT = 110
  110       OPEN (10, file=DATNAM, iostat=ierr, err=820, status='OLD')
* 
*             Read file to preserve existing parms from other progs 
                 Assign 115 to label
                    NSTMT = 115 
  115        READ (10,'(A108)', iostat=ierr, err=820) OBPCHR  
*                        NPROGS is the no of programs in schedule 
                READ (OBPCHR(1:14),'(I2,A6,I6)', iostat=ierr, err=820)
     *                                  NPROGS, OBPNM, LLRN 
             READ (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), 
     *                                             K = 1,NPROGS)
             REWIND 10              ! Get to BOF for writing
* 
       If (OBPNM .NE. PRGNAM) then
* 
               If (IRN .NE. LLRN) then
                   PRINT '((A10)," allocated new RN",(I6)," in place",
     *                            "of old",(I6))', OBPNM, LLRN, IRN 
                   IRN = LLRN 
               endif
* 
*        Write info on this program to disc file, replacing other info
* 
                 Assign 120 to label
                    NSTMT = 120 
  120       WRITE (10, 1200, iostat=ierr, err=820) NPROGS, PRGNAM,
     *                IRN, OB3P4, OB6CM, OB13CM, OB18CM,
     *                ob2p5, ob4p5, 
     *                DUAL34, DUAL6, NADD13, NADD18, nadd25, nadd45 
            WRITE (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), 
     *                                             K = 1,NPROGS)
* 
         endif
                     Assign 160 to label
                         NSTMT = 160
  160              CLOSE (10, iostat=ierr, err=820) 
* 
                   GO TO 900
* 
*      Error handling 
* 
* 
  820   If (ierr .eq. 462) then 
              PRINT '("Disc file ",(A10)," does not exist."/, 
     *                "Run SHPRM on other terminal to create it. ",/
     *                "Hit RETURN when done.",
     *                " _")', DATNAM
              READ '(A1)', DUMCHR 
           GO TO 110
        else
* 
          Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) 
          GO TO label 
        endif 
* 
  900   RETURN
* 
 1200    FORMAT (I2, A6, I6, 12L2, 70X) 
      END 
* 
* 
       END$ 
