FTN77 
$FILES 0,1
$ALIAS/POINT/,NOALLOCATE
      PROGRAM BEAM6 (3,70), SMALL SKY MAP <860731.0900> 
******************************************************* 
C 
C     BEAM MAPPING PROGRAM, ADAPTED FROM SKYMP
C 
      LOGICAL lngscn,  latscn, hastop, decstp, ifbrk, fault, answer 
      REAL    wave(6), raintspec(6), decrtspec(6), tnois(6),
     *        haoff(6), decoff(6), long, lat, maptime 
      INTEGER mes(12), type, wake, cmdcls, cons, dirn,
     *        t(5), y, idvmsl(6), ipram(5)
      EQUIVALENCE (MES(1),LONG),    (MES(3),LAT), 
     *            (MES(5),TYPE),    (MES(6),CMDTIM),
     *            (MES(8),LNGSCN),  (MES(9),LATSCN),
     *            (MES(10),HASTOP), (MES(11),DECSTP), 
     *            (MES(12),WAKE),   (T(2),IS),
     *            (T(3),IM),        (T(4),IH) 
      COMMON /POINT/ LOGCLS,CMDCLS
     *       /LOGCM/ NOBS,NRUN,DECLO,DECHI,NRASTR,RAINT,
     *               DECRT,NSKIP
      DATA CONS /7/,  lu8840 /35/,  dtr /0.017453293/,
     *     TYPE /4/,  LNGSCN /.FALSE./, 
     *     HASTOP /.FALSE./, DECSTP /.FALSE./,
c          ifreq         1       2       3       4       5       6
     *     wave     /   3.6,    6.1,    6.2,   13.0,   18.0,   21.0/, 
     *     idvmsl   /   11b,    33b,    33b,    55b,    77b,     -1/, 
     *     raintspec/ 0.025,   0.05,   0.05,    0.1,   0.15,   0.15/, 
     *     decrtspec/  0.10,   0.15,   0.15,   0.25,   0.30,   0.35/, 
     *     tnois    /  10.0,    6.6,   1.54,   3.96,   11.2,   10.0/, 
     *     haoff    /+0.053, +0.065, +0.046, +0.070, +0.075, +0.000/, 
     *     decoff   /-0.212, -0.075, -0.566, +0.450, +1.750, +0.000/
C 
c     select i/o lu 
      call rmpar(ipram) 
      if (ipram(1) .eq. 1 .or. ipram(1) .eq. 7) cons = ipram(1) 
c     form feed on the anadex 
      if (cons .eq. 7) write (cons,'(a)') char(14b) 
C 
C     PROCEDURE INPATN : GET PARAMETERS FOR OBSERVATIONS
C     ==================================================
C 
*     clear switch register, prevent interruptions
      CALL ISSR(0)
      CALL RNLCK (*90,K)
C     Switch off noise calibration diodes 
      CALL EXEC (2,113B,0,1,3,3)
      CALL EXEC (11,T,Y)
  100 WRITE (CONS,1020) Y,T(5),T(4),T(3)
 1020 FORMAT ('BEAM6 : MULTIFREQUENCY SMALL AREA MAPPING :',
     *        I5,'  DAY',I4,'  at',I4,'H',I3,'M U.T.'/
     *        75('=')/
     *        'To shut down BEAM6 prematurely, type *BR,BEAM6'/ 
     *        'To suspend temporarily (only between rasters), ' 
     *        'set bit 13,'/
     *        'then type *GO,BEAM6 to restart.'// 
     *        'Note that input coordinates must be current ', 
     *        '(precessed),'/ 
     *        'but beam offsets are added by the program.'/)
* 
  200 write (cons,'(''Select Magtape channel 1. Tape number ? _'')')
      read  (cons,*,err=200) mtnumber 
* 
*     Lock tape unit to avoid accidents:
      call lurq (100001B, 9, 1) 
* 
*     write blank leader on tape
      call exec(3,9+1200b)
      call exec(3,9+1200b)
* 
 205  Write (cons,'(/''Available wavelengths are:'' 
     *       6F5.1,'' cm''/ 
     *       ''Wavelength in use ? _'')') (wave(i), i = 1,6)
      read  (cons,*,err=205) wavein 
      do ifreq=1,6
          if (wavein .eq. wave(ifreq)) go to 220
      end do
c     no valid wavelength entered 
      write (cons,'(''illegal : _'')')
          go to 205 
c     valid wavelength entered
 220  if (idvmsl(ifreq) .lt. 1) then
          write (cons,'(''Select wanted radiometer output ''
     *                  ''manually for 8840'')')
      else
          write (cons,'(''Set 8840 input selector to '' 
     *                  ''COMPUTER'')') 
          insel=idvmsl(ifreq) 
          call exec(2,113B,insel,1,5,5) 
      endif 
c     set up fluke 8840 dvm to medium sample rate 
      call rmote (lu8840) 
      write (lu8840,'(''*S1'')')
c 
  224 write (cons,'(/''Low Dec, High Dec of scans ''
     *               ''(current decimal degrees) ? _'')') 
      read  (cons,*,err=224) DECLO, DECHI 
  226 write (cons,'(/''R.A. interval between rasters :''
     *               F5.3,'' deg at '',F4.2,'' cm'' 
     *              /''R.A. interval (decimal degrees) ? _'')') 
     *              raintspec(ifreq), wave(ifreq) 
      read  (cons,*,err=226) RAINT
  228 write (cons,'(/''Dec scan rate :''
     *               f5.3,'' deg/s at '',f4.2,'' cm'' 
     *              /''Dec scan rate (deg/s) ? _'')') 
     *              decrtspec(ifreq), wave(ifreq) 
      read  (cons,*,err=228) DECRT
* 
*     Set up scan timing parameters - time intervals are in UT seconds
      DECLO = PSMOD(DECLO)
      DECHI = PSMOD(DECHI)
      decmean = (declo + dechi) / 2 
*     time at end of up scan
      ENDUP = ABS(PMOD(DECHI - DECLO))/DECRT
*     minimum time to track at start of down scan - was 32 seconds
      BAKTIM = 45 
*     r a interval in seconds 
      SECINT = RAINT*240.0/1.002 737 909 3
*     number of observations per map
      NSKIP = (ENDUP + BAKTIM + SECINT - 1.0)/SECINT
*     time at start of down scan
      STRTDN = FLOAT(NSKIP)*SECINT
*     time at end of down scan
      ENDDWN = STRTDN + ENDUP 
*     time at start of next up scan 
      STRTNX = 2.0*STRTDN 
  230 WRITE (CONS,1210) wave(ifreq),DECLO,DECHI,DECRT,RAINT,
     *                  nskip 
 1210 FORMAT(/'Pattern for 1 observation '
     *        'at',F5.2,'cm wavelength' 
     *       /'Lo dec',F8.3,' Hi dec',F8.3,' Dec rate',F5.3 
     *       /'RA interval',F5.3,' No of rasters',I3
     *       //'OK (T or F) ? _') 
      read (cons,'(l1)',err=230) answer 
      if ( .not. answer ) then
          go to 200 
      endif 
  232 WRITE (CONS,1230) 
 1230 FORMAT (/'Start R.A. (current HH MM SS) ? _') 
      READ (CONS,*,err=232) RAH,RAM,RAS 
      RASTRT = ((RAH*60.0+RAM)*60.0+RAS)/240.0
  234 WRITE (CONS,1240) 
 1240 FORMAT (/'End   R.A. (current HH MM SS) ? _') 
      READ (CONS,*,err=234) RAH,RAM,RAS 
      RAEND = ((RAH*60.0+RAM)*60.0+RAS)/240.0 
      SKIP = FLOAT(NSKIP) 
      NRUNS = PSMOD(RAEND-RASTRT)/(RAINT*SKIP)+1.0
      if (nruns .gt. ((nruns/2)*2)) nruns = nruns + 1 
      drivetime = psmod (raend - rastrt) / 0.4 + 40 
      obstime = drivetime + nruns * (strtnx / 2)
      maptime = nskip * obstime 
      write (cons,'(/29x,''H  M  S'')') 
      write (cons,'(''Time per up+down run pair _'')')
      call wthms (strtnx/240.0,cons)
      write (cons,'(/''Time per '',i3,'' run obs.     _'')') nruns
      call wthms (obstime/240.0,cons) 
      write (cons,'(/''Time per map of'',i3,'' obs.   _'')') nskip
      call wthms (maptime/240.0,cons) 
  222 write (cons,'(/''Number of raster repeats ? _'')')
      read  (cons,*,err=222) IRAS 
      IOBS = IRAS * NSKIP 
c 
  240 write (cons,'(/''Do a noise calibration (T or F) ? _'')') 
      read  (cons,'(l1)',err=240) answer
      if ( answer ) then
          write (cons,'(''Noise cal. assumed to be '',f6.2,'' K'')')
     *        tnois(ifreq)
          call calt2 (cons,lu8840,ifreq,-2,tnois,gascal,fault)
          call calt2 (cons,lu8840,ifreq,-2,tnois,gascal,fault)
      else
       write (cons,'(''No calibration...'')') 
      endif 
C 
C     PROCEDURE RASTR 
C     ================
C 
C     calculate start RA and HA for raster
C 
      istartobs = 1 
      write (cons,'(/''Start at obs number (/ = default = 1) ? _'')') 
      read  (cons,*) istartobs
      nrastr = istartobs - 2
      do nobs = istartobs, iobs 
          nrastr = nrastr + 1 
          if (nrastr .eq. nskip) nrastr = 0 
          nrun = 0
          WRITE (CONS,1300) NOBS,NRASTR 
 1300     FORMAT (//'Observation',I3,'   Raster',I3/) 
          RASOFF = FLOAT(NRASTR)*RAINT
          ra = rastrt + rasoff
          HA = PSMOD(TIME(2)/240.0 - RA)
          WRITE (CONS,1310) 
 1310     FORMAT('Adjusted RA _') 
          CALL WTHMS(RA,CONS) 
          WRITE (CONS,1320) HA
 1320     FORMAT(' Current HA',F8.3)
* 
*         for long and lat parameters passed to steer 
*         add beam offsets
          raoff = haoff(ifreq) / cos(decmean * dtr) 
          offsetra = ra + raoff 
          offsetdeclo = declo + decoff(ifreq) 
          offsetdechi = dechi + decoff(ifreq) 
C 
C         PROCEDURE GETHER
C         ================
C 
C         DRIVE TO START OF OBSERVATION 
C 
          NCMD = CMDCLS 
C         drive and wake
          CMDTIM =-1
          LONG = offsetra 
          LAT = offsetdeclo 
          LATSCN = .FALSE.
          CALL RNRQ(12B,WAKE,ISTAT) 
          CALL EXEC(20,0,MES,12,0,0,NCMD) 
          CALL RNRQ(5,WAKE,ISTAT) 
          CALL RNRQ(40B,WAKE,ISTAT) 
          WAKE = 0
          write (cons,'(''ARRIVED AT START'')') 
C         wait for antenna to settle
          CALL EXEC (12,0,2,0,-20)
          BASETM = TIME(1)
C 
C         PROCEDURE SCNMES
C         ================
C 
C         GENERATE STEERING MESSAGES FOR ONE UP/DOWN SCAN 
C 
          do while (nrun .lt. nruns)
C             upscan
              LONG = offsetra 
              LAT = offsetdechi 
              CMDTIM = BASETM + ENDUP 
              LATSCN = .TRUE. 
              CALL EXEC(20,0,MES,9,0,0,NCMD)
C             track to start of down
              LONG = offsetRA + RAINT*FLOAT(NSKIP)
              CMDTIM = BASETM + STRTDN
              CALL EXEC(20,0,MES,7,0,0,NCMD)
C             downscan
              LAT = offsetDECLO 
              CMDTIM = BASETM + ENDDWN
              CALL EXEC(20,0,MES,9,0,0,NCMD)
C             track to next 
              LONG = offsetRA +  2.0*RAINT*FLOAT(NSKIP) 
              CMDTIM = BASETM + STRTNX
              CALL EXEC(20,0,MES,7,0,0,NCMD)
C 
C             PROCEDURE RUN 
C             ============= 
C 
C             LOG COMPLETE UP/DOWN RUN
C 
*             Reselect DVM inputs before each scan as a precaution
              if (idvmsl(ifreq) .ge. 1) then
                  call exec(2,113b,insel,1,5,5) 
              endif 
              DIRN = 1
              NRUN = NRUN + 1 
              CALL LOGON(CONS,BASETM,BASETM+ENDUP,RA,DIRN)
              if (idvmsl(ifreq) .ge. 1) then
                  call exec(2,113b,insel,1,5,5) 
              endif 
              DIRN = -1 
              NRUN = NRUN + 1 
              RA  = RA + RAINT*FLOAT(NSKIP) 
              offsetra = ra + raoff 
              CALL LOGON(CONS,BASETM+STRTDN,BASETM+ENDDWN,RA,DIRN)
              BASETM = PSMOD((BASETM+STRTNX)/240.0)*240.0 
              RA = RA + RAINT*FLOAT(NSKIP)
              offsetra = ra + raoff 
          end do
*         end of run
*         write eof to tape 
          end file (9)
*         check for break or bit 13 set 
          if (ifbrk(0)) go to 90
          if (issw(13) .lt. 0) then 
              call issr(0)
              pause 'BEAM6 suspended - type GO,BEAM6 to restart'
              call issr(0)
          endif 
      end do
*     end of observations 
   90 call shtdn
      stop 'bye from BEAM6 !' 
      end 
C 
$ALIAS/POINT/,NOALLOCATE
      SUBROUTINE LOGON (CONS, START, ENDTM, RA, DIRN) 
C     ================
C 
C     log one up or down scan on mag tape 
C 
      LOGICAL EOS, LOGERR 
      CHARACTER*1300 CBUF 
      INTEGER YEAR,  DAY, 
     *        T(5),  H,   S,  CONS, 
     *        DIRN,  AREG,
     *        BUF(650), JBUF(650) 
      EQUIVALENCE (BUF, CBUF),
     *            (T(1),MS),(T(2),S),(T(3),M),(T(4),H),(T(5),DAY) 
      COMMON /POINT/ JUNK(11), REALHA 
      COMMON /LOGCM/ NOBS, NRUN, DECLO, DECHI, NRASTR, RAINT, 
     *               DECRT, NSKIP 
C 
      IF (NRUN .EQ. 1) THEN 
          WRITE (CONS,1000) 
 1000     FORMAT(' RUN       RA          UT         HA   DIRN') 
      END IF
C     allocate class number for tape write
      IFUNC = 1 
      ICLASS = 0
      CALL CLRQ (IFUNC,ICLASS)
      CALL EXEC (11,T,YEAR) 
      WRITE (CONS,'(I5,''_'')') NRUN
      CALL WTHMS (RA,CONS)
      CALL WTHMS (START/240.0,CONS) 
      HA = REALHA 
      WRITE (CONS,'(F9.3,I3)') HA, DIRN 
*     write ascii header to output buffer 
      WRITE (CBUF(1:74),2000) NOBS, NRUN, RA, NRASTR, YEAR, DAY, DIRN,
     *                        HA, DECLO, DECHI, RAINT, DECRT, NSKIP 
 2000 FORMAT (I6,I4,4X,F8.3,I2,I5,I4,I3,3F8.3,2F6.3,I2) 
      WAKETM = START - 1.0
      DELAY = TMOD(TIME(1) - WAKETM)
      IF (DELAY .LT. -1.0) CALL EXEC (12,0,2,0,IFIX(DELAY)) 
      NBLOC = 0 
C         repeat 1280 character block 
   10     NSAM = 0
C             repeat readings within block
   20         CALL LOGER (DHA, DDEC, DUT, DVM1, DVM2, LOGERR) 
              IF (.NOT. LOGERR) THEN
                  WRITE (CBUF(80+NSAM*20:99+NSAM*20)) 
     *                DHA, DDEC, DUT, DVM1, DVM2
                  NSAM = NSAM + 1 
              END IF
              EOS = TMOD(ENDTM - DUT) .LT. -1.0 
              IF (.NOT. EOS .AND. NSAM .LT. 60) GO TO 20
C         until end of scan or buffer full
          NBLOC = NBLOC + 1 
*         write block number and number of samples in block to header 
          WRITE (CBUF(11:14),'(i4)') NBLOC
          WRITE (CBUF(75:78),'(i4)') NSAM 
*         class get to remove previous completed class write from the queue 
          IF (NBLOC .NE. 1) CALL EXEC (21,ICLASS+20000B,JBUF,640) 
*         class write the data buffer to mt lu9 
          CALL EXEC (18,9,BUF,640,0,0,ICLASS) 
          IF (.NOT. EOS) GO TO 10 
C     until end of scan 
C     deallocate class number 
      CALL EXEC (21,ICLASS,JBUF,640)
      RETURN
      END 
C 
$ALIAS/POINT/,NOALLOCATE
C 
      SUBROUTINE SHTDN
C     ================
C 
C     CLOSE DOWN HARDWARE PRIOR TO BEAM6 SUSPENSION 
C 
      LOGICAL LNGSCN,  LATSCN,
     *        HASTOP,  DECSTP 
      REAL    LONG,    LAT
      INTEGER MES(12), TYPE,
     *        WAKE,    CMDCLS 
      EQUIVALENCE (MES(1),LONG),   (MES(3),LAT),
     *            (MES(5),TYPE),   (MES(6),CMDTIM), 
     *            (MES(8),LNGSCN), (MES(9),LATSCN), 
     *            (MES(10),HASTOP),(MES(11),DECSTP),
     *            (MES(12),WAKE)
      COMMON /POINT/ LOGCLS,CMDCLS
      DATA TYPE /2/, LONG /0.0/, LAT /334.114/, CMDTIM /-1.0/,
     *     LNGSCN /.FALSE./, LATSCN /.FALSE./, HASTOP /.TRUE./, 
     *     DECSTP /.TRUE./
C 
C        WRITE ANOTHER TAPE MARK
C 
         CALL EXEC (3,9+100B) 
C 
C        REWIND TAPE AND PARK ANTENNA 
            CALL EXEC (3,9+400B)
            NCMD = CMDCLS 
            CALL EXEC (20,0,MES,12,0,0,NCMD)
         RETURN 
      END 
C 
C 
      SUBROUTINE WTHMS (ANGLE,CONS) 
C     ============================= 
C 
C     WRITE ANGLE IN H M S
C 
         INTEGER CONS 
         S = PSMOD(ANGLE) + 0.05/240.0
         IH = S/15.0
         S = (S - FLOAT(IH)*15.0)*240.0 
         M = S/60.0 
         S = S - FLOAT(M)*60.0
         WRITE (CONS,1000) IH,M,S 
 1000    FORMAT('  ',I2,':',I2,':',F4.1,'_')
         RETURN 
      END 
      FUNCTION PSMOD(ANGLE) 
C     ======================
C 
         PSMOD = ANGLE - FLOAT(IFIX(ANGLE/360.0))*360.0 
         IF(PSMOD.LT.0.0) PSMOD = PSMOD + 360.0 
         RETURN 
      END 
      FUNCTION TIME(N)
C     ============= 
C 
         INTEGER T(5),YR,H,S,D
         EQUIVALENCE   (T(1),MS),(T(2),S),
     *                 (T(3),M), (T(4),H),
     *                 (T(5),D) 
         DATA     BASEOF/84806.882/,     LSTDAY /0/ 
C 
         CALL EXEC(11,T,YR) 
         TIME = FLOAT(H*60 + M)*60.0 + FLOAT(S) + FLOAT(MS)/100.0 
         IF (N.LT.2) RETURN 
* 
*CORRECT VERSION ALLOWING FOR LEAP YEARS: 
         IF (D .NE. LSTDAY) 
     *      OFFSET = FLOAT((YR-1979)*365 + (YR-1977)/4 + D -258)
     *               *236.55536 + BASEOF + 6644.4 
* 
         TIME = TIME*1.002 737 909 3 + OFFSET 
         TIME = TIME - FLOAT(IFIX(TIME/86400.0))*86400.0
         RETURN 
      END 
      FUNCTION PMOD(ANGLE)
C     ====================
C 
C     RETURNS A VALUE OF ANGLE IN PMOD, -180.0<PMOD<180.0 
C 
         PMOD = ANGLE + 180.0 
         PMOD = PMOD - FLOAT(IFIX(PMOD/360.0))*360.0
         IF (PMOD.LT.0.0) PMOD = PMOD + 360.0 
         PMOD = PMOD - 180.0
         RETURN 
      END 
      FUNCTION TMOD(TIME) 
C     =================== 
C 
C     RETURNS VALUE  -43200.0< TMOD <43200.0
C 
         TMOD = TIME + 43200.0
         TMOD = TMOD - FLOAT(IFIX(TMOD/86400.0))*86400.0
         IF (TMOD.LT.0.0) TMOD = TMOD + 86400.0 
         TMOD = TMOD - 43200.0
         RETURN 
      END 
* 
      SUBROUTINE CALT2 (CONS,lu8840,IFREQ,NTSETTLE,TNOIS, 
     *                  GASCAL,FAULT), calibrate receiver 
************************************************************************
*  Noise calibration for DVM units to Kelvins conversion
*  Modified to take out linear slope while sampling 
* 
*  Inputs:  CONS      I/O logical unit
*           lu8840    lu of 8840 dvm in use 
*           IFREQ     frequency index 
*           NTSETTLE  radiometer settling time (seconds)
*           TNOIS     noise cal. temperature array
* 
*  Outputs: GASCAL    DVM units per Kelvin conversion factor
*           FAULT     set true if 10 calibration failures occur 
* 
*  IFREQ: 1=3.4cm, 2=6.1cm, 3=6.2cm, 4=13cm, 5=18cm, 6=21cm 
* 
      LOGICAL  FAULT, overflow
      INTEGER  NVALID(4) , CONS 
      REAL     TNOIS(6) 
      DOUBLE PRECISION DVM(4), DVMSQD(4), ADVM(4), DMS(4), RMS(4),
     *                 RDVM, RMS_SUM, DMS_SUM, TUBE_COUNT 
* 
*     Set up system for gain calibration
*     ----------------------------------
      retries = 0 
      number = 40 
      FAULT = .FALSE. 
      write (cons,'(/9X,''Receiver calibration :'')') 
* 
*         Restart point after error  - allow for up to 10 failures
*         --------------------------------------------------------
   10     retries = retries + 1 
          DMS_SUM = 0D0 
          RMS_SUM = 0D0 
* 
*         Sample with noise diode off (J = 1,4) or on (J = 2,3) 
*         ----------------------------------------------------
          DO J = 1, 4 
              DVM(J)  = 0D0 
              DVMSQD(J) = 0D0 
              NVALID(J)  = 0
*             turn on noise cal diode 
              IF (J .EQ. 2) CALL EXEC (2,113B,IFREQ,1,3,3)
*             turn off noise cal diode
              IF (J .EQ. 1 .OR. J .EQ. 4) call exec (2,113b,0,1,3,3)
*             wait to settle
              IF (J .NE. 3) CALL EXEC (12,0,2,0,NTSETTLE) 
* 
*             Sample 0.1 sec filtered 'direct' radiometer output
*             --------------------------------------------------
              DO I = 1,number 
                 read (lu8840,*,err=20) rdvm
*                Store DVM and DVM SQUARED readings 
                 NVALID(J) = NVALID(J) + 1
                 DVMSQD(J) = DVMSQD(J) + RDVM * RDVM
                 DVM(J) = DVM(J) + RDVM 
   20         continue
              end do
* 
*             Sampling done: calculate average DVM reading and rms error
*             --------------------------------------------------------- 
              NFAILURES = number - NVALID(J)
              if (nfailures .gt. 0) then
                  write (cons,'(I4,'' 8840 read errors'')') nfailures
              endif 
* 
              IF (NVALID(J) .gt. 2) then
*                 average reading 
                  ADVM(J) = DVM(J) / NVALID(J)
                  DMS(J) = (DVMSQD(J) - DVM(J)*DVM(J)/NVALID(J))
     *                      / (NVALID(J) - 1.0) 
                  DMS_SUM = DMS_SUM + DMS(J)
*                 rms error in mean 
                  RMS(J) = DSQRT(DMS(J))
                  RMS_SUM = RMS_SUM + RMS(J)
* 
                  IF (J .EQ. 1 .OR. J .EQ. 4) then
                      write (cons,'(6X,''Noise cal. off : _'')')
                  endif 
                  IF (J .EQ. 2 .OR. J .EQ. 3) then
                      write (cons,'(6X,''Noise cal.  on : _'')')
                  endif 
                  write (cons,'(''8840 Average = '',F12.6,'' +-'',
     *                        f12.6,'' V'')') advm(j), rms(j) 
              endif 
          end do
* 
*         Error checks
*         ------------
          if (retries .ge. 10) then 
              fault = .true.
              write (cons,'(''Abandoning calibration'')') 
              return
          endif 
* 
*         No more than 20% overflows allowed
          do 40 j = 1,4 
              if (nvalid(j) .lt. (0.8*number)) then 
                  write (cons,'(''Excessive overflows - try again'')')
                  go to 10
              endif 
  40          continue
* 
*         Check noise cal. > 4 * average rms noise
          TUBE_COUNT = ((ADVM(2) + ADVM(3)) - (ADVM(1) + ADVM(4)))/2
          if (DABS(TUBE_COUNT) .lt. (RMS_SUM/2)) then 
              write (cons,'(''Noise cal not seen - try again'')') 
              go to 10
          endif 
* 
*     Else calculate DVM units per Kelvin conversion factor 
*     ----------------------------------------------------- 
      GASCAL = TUBE_COUNT / TNOIS(IFREQ)
* 
*     Fractional error in GASCAL is the square root of the sums of the
*     squares of the fractional errors in the difference between the
*     two DVM averages. 
* 
      DGAS = GASCAL * DSQRT ((DMS_SUM*2 / TUBE_COUNT**2)) 
      DGAS = ABS (DGAS) 
      write (cons,'(9X,''Volts per Kelvin ='',F9.6,'' +-'', 
     *            f9.6)') gascal, dgas
      return
      end 
* 
      SUBROUTINE LOGER (HA, DEC, UT, DVM1, LOGERR)
C=======================================================================
C 
C     read antenna coordinates, time and dvms 
C 
      LOGICAL   LOGERR
      INTEGER   IBUF(6), T(5), YEAR, H, M, S, MS
      REAL      ha, DEC, UT 
      CHARACTER CBUF*12 
      EQUIVALENCE (IBUF, CBUF), (MS, T(1)), (S, T(2)),
     *            (M, T(3)), (H, T(4))
C 
C     read from fluke 8840 dvm
      read (35,*,err=10) dvm1 
C     read from dio (input, ascii immediate, into ibuf, 6 words, dio 1-3) 
      CALL EXEC (1,0B + 13B,IBUF,6,1,3) 
C     get time (ut) 
      CALL EXEC (11,T,YEAR) 
      UT = FLOAT(H*60 + M)*60.0 + FLOAT(S) + FLOAT(MS)/100.0
C     decode hour angle 
C     mask out sign and tach bits 
      IBUF(1) = IBUF(1) .AND. 171777B 
C     read ascii equivalent and convert to degrees
      READ (CBUF(1:6),'(I3,I3)',ERR=10) IHAU, IHAL
      HA = FLOAT(IHAU) + FLOAT(IHAL)/1000.0 
C     decode declination
C     mask out sign and tach bits 
      IBUF(4) = IBUF(4) .AND. 171777B 
C     read ascii equivalent and convert to degrees
      READ (CBUF(7:12),'(I3,I3)',ERR=10) IDECU, IDECL 
      DEC = FLOAT(IDECU) + FLOAT(IDECL)/1000.0
      LOGERR = .FALSE.
      RETURN
C         error return
   10     LOGERR = .TRUE. 
          RETURN
      END 
* 
$ALIAS RNRQ, NOABORT
      SUBROUTINE RNLCK (k,*)
C=======================================================================
*     Subroutine to read RNs from file ALCRNS, and lock onto all
*     of them. This is for a non-interruptible program
  
      CHARACTER NAMFIL*10 
      INTEGER   IRN(20), SWIN 
      DATA      NAMFIL /'ALCRNS::16'/, lu / 1 / 
* 
      CALL FSYSU (LU,LU)
* 
*     Open, read and close file 
      Assign 110 to label 
      NSTMT = 110 
  110 OPEN (10, file=NAMFIL, iostat=ierr, err=820, status='OLD')
      do nno = 1,20 
          Assign 120 to label 
          NSTMT = 120 
  120     READ (10,*,iostat=ierr, err=820, end=150) IRN(NNO)
      end do
  150 Assign 160 to label 
      NSTMT = 160 
  160 CLOSE (10, iostat=ierr, err=820)
* 
*     Lock all RNs LOCALLY
      PRINT '(//6X,"RNs allocated by scheduling"/ 
     *          6X,"programs :")' 
      PRINT '(16X,I6)', (IRN(L), L=1,NNO-1) 
      DO KRN = 1,NNO-1
          PRINT '("Attempt to lock RN ",I6)', IRN(KRN)
*         globally set RN, with no wait and no abort
          ICON = 140001B
          CALL RNRQ (ICON, IRN(KRN), ISTAT, *170) 
  170     if (ISTAT .eq. 2) then
              PRINT '("RN ",I6," locked OK. Status",I6)',IRN(KRN),ISTAT 
          else if (ISTAT .EQ. 6) then 
*             RN already locked 
              PRINT '(/"RN ",I6," locked to another program."/, 
     *                    3X,"Find out which and turn it OFF, else"/
     *                    3X,"this program may be interrupted."/)', 
     *            IRN(KRN)
          else if (ISTAT .EQ. 3 .OR. ISTAT .EQ. 7) then 
              PRINT '(/"RN ",I6," locked GLOBALLY")', IRN(KRN)
          else if (ISTAT .EQ. 0) then 
              PRINT '(/"RN ",I6," is NOT ALLOCATED")', IRN(KRN) 
          else
              PRINT '("Error for RN ",I6," Status",I6," ICON= ",O6)', 
     *            IRN(KRN), ISTAT, ICON 
          endif 
      end do
*     S-register bit 12 set for SCHEDULE OVERIDE
  900 ISWIT = SWIN(0) 
      ISWIT = ISWIT .OR. 10000B 
      CALL SWOUT (ISWIT)
      RETURN k
* 
*         File errors 
  820     If (ierr .eq. 462) then 
            PRINT '("File ",A," does not exist ie. no RNs allocated")', 
     *          NAMFIL
            GO TO 900 
          else
              print '("error ",i4," in file ",a)',ierr,namfil 
          endif 
          Call ERMSG (ierr, NSTMT, *900, k) 
          GO TO label 
* 
      END 
* 
      SUBROUTINE ERMSG (ierr, NSTMT, k,*) 
************************************************************************
*     subroutine to display errors
      LOGICAL AOK 
* 
      PRINT '("Error ",(I4)," at statement",(I4))', ierr, NSTMT 
      PRINT '("OK(T) or end program(F) ? _")' 
          READ '(L1)', aok
          If (.NOT. aok)  k=1 
      RETURN k
      END 
