FTN77
$FILES 0,2
      PROGRAM SPECC (3,65)
**********************************************************************
*     Version : <981116.1106>
*     256 channel spectral line observing program.
*     Programs ACFIN, SPPLO, ALARM, DPRC2 must be compiled and loaded.
*     Source code is in /MIKE/PROGS/SPECC.FTN on control computer
*     Compile onto CR 16, then for a permanent load (for SCHDLing)
*     LOADR:IH         (InHibit cloning)
*     OP,RPEB          (replace permanent program, extended background)
*     FM,MP            (mixed page linkages, permit cloning)
*     RE %SPECC::16
*     EN
*
*     INCLUDES files from /MIKE/PROGS/ on control computer -
*     see end of this listing.
*
*   history:
*     written by MJG 1979...
*   SPECF 1991 04 03 revised CALT in SPCAL.SUB for AGC'd video amp
*     mod 1991 08 23 include 6.6 GHz (4.5S) methanol receiver system
*     mod 1991 10 24 std LO for 18 changed to 268MHz for RF filters.
*   SPECG 1991 11 17 2.5 cm LO 1 set up simplified - computer control
*                    of synthesizer removed for LO 1
*                    std LO freq for 2.5 changed to 260.0 MHz
*   SPECH 1992 02 19 revised scheduling subroutines for 2.5, 4.5 cm
*   SPECI 1992 03 27 video square law detector replaces HP3400
*                    set HP3336 to 22.0 MHz for 2.5 cm
*                    read noise cal from disc file SYPARM::16
*     mod 1992 04 13 read / write last obs number to disc file SPLAST::15
*     mod 1992 06 06 shift housekeeping printout to minimise paper waste
*     mod 1992 07 30 fix error opening splast occurring repeatedly
*     mod 1992 08 24 set LO to DSYNOF after interruption (for 1720)
*   SPECJ 1992 09 29 fix truncation in synth freq calculation
*     mod 1992 11 17 update scheduling, can ZE if interrupted
*   SPECK 1993 04 07 cosmetic changes to printout
*   SPECL 1993 05 22 plot to HP150 + printer in place of HP7210
*   SPECM 1993 08 20 to minimise printout, keep Trad.
*   SPECN 1993 09 01 make schedulable
*     mod 1993 11 25 change 4.5 XMC from 6 to 2 to permit 5 cm operation
*     mod 1993 11 27 change 4.5 XMC from 2 to 6 because GN changed back
*   SPECO 1993 12 15 add 5 cm receiver
*     mod 1993 12 24 subroutine CHKLO removed, replaced by call to CALT
*     mod 1993 12 30 changes to try to find fault with calibration
*     mod 1994 01 07 changes to F3336 error detection
*     mod 1994 01 14 add TCALK noise diode value to housekeeping
*   SPECP 1994 01 20 add observing log calls to OBSLG
*     mod 1994 02 21 comment out option for alternate synth at 5 cm
*     mod 1994 05 03 set bit 12 if parameter 3 = 0 for no schedule
*   SPECQ 1994 08 01 select new GPR input (IDVMSL = 66B, was 67B)
*   SPECR 1994 09 19 kill TEMPS on startup, pauses added in F8662
*   SPECS 1994 10 06 check HP8662 status and frequency after freq set
*   SPECT 1994 11 24 calculate Vlsr at centre of each half of observation
*     mod 1994 11 29 write spectrum to alternate file if file error occurs
*     mod 1995 01 26 add warning messages about interfering signals
*   SPECU 1995 03 30 add 18U untilted option, permit cloning
*     mod 1995 04 18 add ERRFMP to report FMP errors
*     mod 1995 06 22 RTHUM revised for new meter, check new file name length
*     mod 1995 08 01 correct VSYNON R*8; R*4 since SPECT 1994 11 24
*   SPECV 1995 08 03 strong typing in master segment
*         1995 08 15 call to XBELL after bit 10 set deleted
*   SPECW 1995 09 20 all calls to lu 36 commented out after 8840 failure
*                    IDVMSL changes, RTHUM commented out, RHYP changed,
*                    old version of CALT for lu35+36 to SPCAL3536.SUB,
*                    new version of CALT for lu35 only to SPCAL35.SUB
*   SPECX 1995 10 18 add VIDLEV.SUB to check video signal level
*         1996 04 17 check 18cm polarization using CALK from SYPARM
*   SPECY 1996 05 02 read 18cm polarization via DIO ch 7, use to set CALK
*   SPECZ 1996 10 29 add 3.5cm system, commonlus.sub
*   SPECZ 1997 04 30 change 2.5 first LO 10560 to 10510 MHz DRO
*   SPECA 1997 07 24 revert to check 18cm Pol using CalK from SYPARM
*   SPECA 1997 07 24 fix ANTBUF / COORD2 equiv in PSUSPD
*   SPECB 1997 09 17 change 4.5cm LO mult factor IXMC from 6 to 2
*   SPECC 1998 11 16 change LOs to 160MHz systems
*
*     Run with run string parameters NNNN, M, L
*     where NNNN is the number of the SPnnnn source file on CR16
*           M is the source number to start at in the source file,
*           L is 0 if SCHDL'd, 1 if not SCHDL'd
*
C     Spectral line source file SPnnnn::16 parameters for SPECC :
C
C     line 1 (free format):
C     ---------------------
C     VARIABLE  TYPE        USE
C     name    character*20  source name, in quotes
C     ktype   character*2   coordinate type, in quotes
C                           'CE' for 1950 RA/DEC
C                           'GA' for Galactic LII/BII
C     nacc    integer*2     number of correlator accumulations
C                           in each position
C     nobs    integer*2     number of observations of this position pair
C     kount   integer*2     octal correlator thumbwheel count,
C                           written as  @37777 for example
C     bw      real*4        correlator bandwidth in MHz eg 0.32
C     synofAB real*8        synthesizer offset in Hz applied to both A (up)
C                           and B (down) spectra, to put line in passband.
C                           If zero, 0 km/s Vlsr is centered in the spectrum.
C     synofB  real*8        synthesizer offset in Hz applied to B (down)
C                           spectrum ONLY.  Set to zero if not used.
C                           it allows frequency switching observations
C
C     line 2 (free format):
C     ---------------------
C     OUTFILE character*20  output file name for storing spectra on disc
C     coord1  real*4        position A, either 1950 RA  or LII
C                           in H M S or decimal degrees
C     coord2  real*4        position A, either 1950 DEC or BII
C                           in D ' " or decimal degrees
C     raofB   real*4        offset applied to position A RA (1950)
C                           for position switching to get position B
C                           must be in decimal degrees. Can be zero.
C     dcofB   real*4        offset applied to position A DEC (1950)
C                           for position switching to get position B
C                           must be in decimal degrees. Can be zero.
C     dfreq   real*8        line rest frequency in MHz
C
C     Note that at least one of synofB, raofB, dcofB must be non-zero
C
C     Example of a source file for 18 cm with 2 sources :
C
C    'POSITION SWITCHING '  'CE'  1 4  @37777  1.28       0     0
C    'DATA01::15'   13 30 45 -30 21 35  -1.0 0    1612.231
C    'FREQUENCY SWITCHING'  'GA'  1 4  @37777  1.28   -4000  +106667
C    'DATA02::15'   350.000 -1.000 0  0        1612.231
C
      IMPLICIT NONE
C
      INTEGER*2 NSYS              ! number of receiver systems
      PARAMETER (NSYS = 7)
C
      CHARACTER B15MES*10         ! message if bit 15 set
      CHARACTER CBUFFER*20        ! angle readout buffer = BUFFER
      CHARACTER CLOG*76           ! log message string
      CHARACTER DIGBUF*4          ! buffer for source file digits
      CHARACTER KTYPE*2           ! coordinate type CE/GA
      CHARACTER MODE*2            ! FS freq switch or PS position sw
      CHARACTER NAME*20           ! source name, 20 chars, in IDATA
      CHARACTER OUTFILE*20        ! output file name, for WRTSPF, in IDATA
      CHARACTER POL18CM*7         ! 18 cm pol read from DIO channel 7
      CHARACTER PRGNAM*6          ! program name (for SCHDL)
      CHARACTER RCVMES*14         ! receiver fault message
      CHARACTER READMES*23        ! cannot read source file message
      CHARACTER SETMES*15         ! all sources set message
      CHARACTER SOURCEFILE*10     ! source file name
      CHARACTER SRCMES*19         ! invalid source file message
      CHARACTER STOPMES*19        ! STOP in source file message
      CHARACTER STRMES*17         ! invalid runstring message
      CHARACTER SYSTEM(NSYS)*4    ! receiver system identifiers
      CHARACTER TUNIT*2           ! brightness units K/Jy, in IDATA
      CHARACTER WRTMES*16         ! file write error message
*
      LOGICAL   CHECKVID          ! true to check video level in CALT
      LOGICAL   DOWAIT            ! true to execute WAITs in src file
      LOGICAL   DRIVEWAIT         ! true to wait for drive, in ANTBUF
      LOGICAL   FAULT             ! true if fault detected
      LOGICAL   FILE_ERROR        ! true if error in disk file i/o
      LOGICAL   FILE_END          ! true if end of source file reached
      LOGICAL   FOLDED            ! true if spectrum folded, in IDATA
      LOGICAL   INTERRUPTIBLE     ! true if interruptible by SCHDL
      LOGICAL   NEWSOURCE         ! true if bit 10 set for new source
      LOGICAL   PSUSPD1           ! true if SCHDLd program interrupted
      LOGICAL   PSUSPD2           ! true if bit 13 set
      LOGICAL   READ_ERROR        ! true if error reading source file
      LOGICAL   TRACK             ! true to track RA, in ANTBUF
      LOGICAL   WESTLIM           ! true if horizon reached in next obs
C
      INTEGER*2 ACFIN(3)          ! ACFIN name for exec call
      INTEGER*2 ALARM(3)          ! ALARM name for exec call
      INTEGER*2 ANTBUF(7)         ! parameter buffer for DRIVE
      INTEGER*2 BUFFER(10)        ! angle readout buffer
      INTEGER*2 DPRC2(3)          ! DPRC2 name for exec call
      INTEGER*2 DRIVE(3)          ! DRIVE name for exec call
      INTEGER*2 I                 ! generic do loop index
      INTEGER*2 IBITCLEAR         ! S reg bit pattern for SCHDL
      INTEGER*2 ICHAR             ! number of characters in string
      INTEGER*2 ID                ! start of obs, day (UT), in IDATA
      INTEGER*2 ID1               ! start index for source file number
      INTEGER*2 IDATA(700)        ! spectrum + housekeeping block
      INTEGER*2 IDVMSL(NSYS)      ! DVM select code via DIO
      INTEGER*2 IEND              ! > 0 if STOP or ZENITH in src file
      INTEGER*2 IFIRST            ! number of first observation
      INTEGER*2 IH                ! start of obs, hour (UT), in IDATA
      INTEGER*2 ILOG(38)          ! log buffer for OBSLG, = CLOG
      INTEGER*2 IM                ! start of obs, minute (UT), in IDATA
      INTEGER*2 INDEX             ! array index of receiver in use
      INTEGER*2 IOBSERVATION      ! number of current observation
      INTEGER*2 IOBS1             ! previos observation number, in IDATA
      INTEGER*2 IOS               ! file i/o error code
      INTEGER*2 IOUTREC           ! outfile record num from WRTSPF, in IDATA
      INTEGER*2 IP(5)             ! collect and pass parms in exec calls
      INTEGER*2 IPB(20)           ! array indicies of poly fit, in IDATA
      INTEGER*2 IPLOT             ! plot type for SPPLO
      INTEGER*2 IPOLY             ! degree of baseline poly, in IDATA
      INTEGER*2 IRN               ! resource number from RNALC
      INTEGER*2 IS                ! start of obs, second (UT), in IDATA
      INTEGER*2 ISWIT             ! switch register setting
      INTEGER*2 ISYNTH(NSYS)      ! HP RF synthesizer model number
      INTEGER*2 ITIME(5)          ! time parameters from exec call
      INTEGER*2 ITYPE             ! drive type (4) for DRIVE, in ANTBUF
      INTEGER*2 IY                ! start of obs, year, in IDATA
      INTEGER*2 IW                ! smoothing window type, in IDATA
      INTEGER*2 IXMC(NSYS)        ! LO chain multiplication factor
      INTEGER*2 J                 ! do loop index
      INTEGER*2 KOUNT             ! octal correlator thumbwheel count
      INTEGER*2 LASTSOURCE        ! last source in source file
      INTEGER*2 LBUF(700)         ! large buffer for spectra file write
      INTEGER*2 LOSIGN            ! sign for adding offsets to LO
      INTEGER*2 LU                ! standard output lu for messages, in LUS
      INTEGER*2 LU150             ! HP150 graphics VDU LU number
      INTEGER*2 LU3330            ! lu of hp3330 on hpib (obsolete), in LUS
      INTEGER*2 LU3336            ! lu of hp3336 on hpib, in LUS
      INTEGER*2 LU8662            ! lu of hp8662 on hpib, in LUS
      INTEGER*2 LU8840A           ! lu of hp8840A on hpib, in LUS
      INTEGER*2 LU8840B           ! lu of hp8840B on hpib, in LUS
      INTEGER*2 MWAIT             ! wait time for source to rise (mins)
      INTEGER*2 MTLU              ! mag tape logical unit, in LUS (not used)
      INTEGER*2 N1                ! array index start of spectrum, in IDATA
      INTEGER*2 N2                ! array index end   of spectrum, in IDATA
      INTEGER*2 NACC              ! number of accumulations per spectrum
      INTEGER*2 NCHAR             ! number of non-blank chars in string, func
      INTEGER*2 NDSEL(NSYS)       ! cal noise diode selection via DIO
      INTEGER*2 NEXTOP            ! 0 start, 1 continue, 2 next src, 3 end
      INTEGER*2 NOBS              ! number of observations of this source
      INTEGER*2 NOTUP             ! number sources attempted below west hor
      INTEGER*2 NREADERRORS       ! number of source file read errors
      INTEGER*2 NREC              ! unused parameter for SUSPD
      INTEGER*2 NSOURCE           ! source number to start at in file
      INTEGER*2 NSP               ! number points in spectrum, in IDATA
      INTEGER*2 OBSLG(3)          ! OBSLG program name for exec call
      INTEGER*2 OFFACFIN(5)       ! OFF,ACFIN message for MESSS
      INTEGER*2 OFFDRIVE(5)       ! OFF,DRIVE message for MESSS
      INTEGER*2 SPPLO(3)          ! SPPLO program name for exec call
      INTEGER*2 SWIN              ! switch register value, function call
*
      REAL*4    ACOORD            ! for coordinate precession, in IP
      REAL*4    ADAV              ! number of spectra in average
      REAL*4    AIRHUM            ! outside air humidity, %, in DATA
      REAL*4    AIRTEMP           ! outside air temperature, deg C, in DATA
      REAL*4    AITOKMS           ! array index to km/s conversion, in DATA
      REAL*4    ANTDC             ! dec at end of observation, in DATA
      REAL*4    ANTHA             ! ha  at end of observation, in DATA
      REAL*4    AONDEC            ! source DEC precessed to date
      REAL*4    AONRA             ! source RA  precessed to date
      REAL*4    AVERAGE           ! number of spectra averaged, in DATA
      REAL*4    AVRG(256)         ! average spectrum
      REAL*4    BCOORD            ! for coordinate precession, in IP
      REAL*4    BW                ! correlator bandwidth, MHz, in DATA
      REAL*4    COMHA             ! command hour angle
      REAL*4    COORD1            ! RA/LII for DRIVE, in ANTBUF
      REAL*4    COORD2            ! DC/BII for DRIVE, in ANTBUF
      REAL*4    COUNT             ! correlator thumbwheel count + 1
      REAL*4    DATA(350)         ! =IDATA=DDATA
      REAL*4    DC50A             ! dec 1950 of position A, in DATA
      REAL*4    DC50B             ! dec 1950 of position B, in DATA
      REAL*4    DCBOFF            ! dec beam offset used, in DATA
      REAL*4    DECBM(NSYS)       ! dec beam offset of system
      REAL*4    DECREF            ! DEC offset for reference position
      REAL*4    DIFF(256)         ! difference spectrum
      REAL*4    DNOISE(NSYS)      ! cal noise diode value (K)
      REAL*4    DTDUM             ! dTsys on startup, after interrupt
      REAL*4    DTR               ! degrees to radians conversion
      REAL*4    DTRDUM            ! dTradsys on startup, after interrupt
      REAL*4    DTSONA            ! dTsys in position A
      REAL*4    DTSONB            ! dTsys in position B
      REAL*4    DTSYSA            ! error in system temp. on A, in DATA
      REAL*4    DTSYSB            ! error in system temp. on B, in DATA
      REAL*4    DTSYSR            ! dTradsys in position A, in DATA
      REAL*4    HACOM             ! HA of given RA, function call
      REAL*4    HALIM             ! HA limit at given DEC, function call
      REAL*4    OBSTIME           ! est. total time of 1 observation (mins)
      REAL*4    OFFDEC            ! ref DEC precessed + beam offsets
      REAL*4    ONDEC             ! source DEC precessed + beam offsets
      REAL*4    OFFRA             ! ref RA  precessed + beam offsets
      REAL*4    ONRA              ! source RA  precessed + beam offsets
      REAL*4    RA50A             ! ra  1950 of position A, in DATA
      REAL*4    RA50B             ! ra  1950 of position B, in DATA
      REAL*4    RABM(NSYS)        ! RA beam offset of system
      REAL*4    RABOFF            ! ha  beam offset used, in DATA
      REAL*4    RAREF             ! RA offset for reference position
      REAL*4    REF(256)          ! reference spectrum
      REAL*4    RFMAX(NSYS)       ! max RF of receiver, for getting INDEX
      REAL*4    SCALEJY           ! JY to K conversion, in DATA
      REAL*4    STDFOCUS(NSYS)    ! standard subref focus of system
      REAL*4    STDTILT(NSYS)     ! standard subref tilt of system
      REAL*4    SUBFOCUS          ! subreflector focus position, in DATA
      REAL*4    SUBTILT           ! subreflector tilt position, in DATA
      REAL*4    TCALK             ! cal noise diode temp used, in DATA
      REAL*4    TDUM              ! Tsys on startup, after interrupt
      REAL*4    TINT              ! integrate time, secs on source, in DATA
      REAL*4    TRDUM             ! Tradsys on startup, after interrupt
      REAL*4    TRMS              ! theoretical RMS noise in spectrum, in DATA
      REAL*4    TSONA             ! Tsys on position A
      REAL*4    TSONB             ! Tsys on position B
      REAL*4    TSYSA             ! system temperature on A, in DATA
      REAL*4    TSYSB             ! system temperature on B, in DATA
      REAL*4    TSYSR             ! Tradsys on position A, in DATA
      REAL*4    WAVE(NSYS)        ! receiver standard wavelength
      REAL*4    YSCALE            ! y axis plot scale, in DATA, obsolete
      REAL*4    YOFSET            ! y axis plot offset, in DATA, obsolete
      REAL*4    ZVLINDEX          ! array index of 0 Vlsr, in DATA
*
      REAL*8    ALAT              ! observatory latitude (south neg deg)
      REAL*8    DBW               ! correlator bandwidth (MHz)
      REAL*8    DDATA(175)        ! =IDATA=DATA
      REAL*8    DFOF              ! frequency offset, posn A, in DDATA
      REAL*8    DFOFB             ! frequency offset, posn B, in DDATA
      REAL*8    DFREQ             ! line rest frequency (MHz), in DDATA
      REAL*8    DJ                ! Julian date, start of obs
      REAL*8    DJP               ! Juldate, start of prev obs, in DDATA
      REAL*8    DM6               ! 1e-6
      REAL*8    DOPFREQOF         ! posn B doppler-shifted freq
      REAL*8    DOPFREQON         ! posn A doppler-shifted freq
      REAL*8    DSYNOF            ! posn B synth freq
      REAL*8    DSYNOFP           ! posn B synth freq prev obs, in DDATA
      REAL*8    DSYNON            ! posn A synth freq
      REAL*8    DSYNONP           ! posn A synth freq prev obs, in DDATA
      REAL*8    DXMC              ! LO chain mult factor, in DDATA
      REAL*8    ELEV              ! observatory elevation (meters amsl)
      REAL*8    FIRSTLO           ! first LO frequency (MHz)
      REAL*8    OLONG             ! observatory longitude (east neg deg)
      REAL*8    RELCOR            ! doppler shift correction factor
      REAL*8    STDLO(NSYS)       ! standard LO freq of receiver (MHz)
      REAL*8    SYNOFS            ! synth offset for posns A & B (Hz)
      REAL*8    SYNRF             ! synth offset for posn B only (Hz)
      REAL*8    VLIGHT            ! velocity of light (km/s)
      REAL*8    VSYNOF            ! synth dop cor offset for posn B
      REAL*8    VSYNON            ! synth dop cor offset for posn A
      REAL*8    VLSROF            ! vlsr correction for B obs
      REAL*8    VLSRON            ! vlsr correction for A obs
      REAL*8    XMC25             ! 2.5 cm mult factor, 1st LO
*
*     DATA / IDATA / DDATA hold the spectrum and housekeeping info.
*
      EQUIVALENCE
     & (DATA(1), IDATA(1)),       ! real*4 & integer*2 arrays
     & (DATA(1), DDATA(1)),       ! real*8 & real*4    arrays
*
     & (NAME,    IDATA(517)),     ! source name, 20 characters
     & (IY,      IDATA(527)),     ! start of obs, year
     & (ID,      IDATA(528)),     ! start of obs, day (UT)
     & (IH,      IDATA(529)),     ! start of obs, hour
     & (IM,      IDATA(530)),     ! start of obs, minute
     & (IS,      IDATA(531)),     ! start of obs, second
     & (IW,      IDATA(532)),     ! smoothing window type
     & (IOBS1,   IDATA(533)),     ! observation number
     & (IPOLY,   IDATA(534)),     ! degree of baseline polynomial
     & (NSP,     IDATA(535)),     ! number of points in spectrum
     & (N1,      IDATA(536)),     ! array index of start of spectrum
     & (N2,      IDATA(537)),     ! array index of end   of spectrum
     & (TUNIT,   IDATA(538)),     ! intensity unit, K or JY, 2 char
     & (FOLDED,  IDATA(539)),     ! spectrum folded, logical check
     & (IPB(1),  IDATA(540)),     ! array indecies of poly fit blocks
     & (IOUTREC, IDATA(690)),     ! outputfile record number from WRTSPF
     & (OUTFILE, IDATA(691)),     ! outputfile name for WRTSPF
*
     & (BW,      DATA(291)),      ! correlator bandwidth, MHz
     & (TINT,    DATA(292)),      ! integration time, seconds on source
     & (TSYSA,   DATA(293)),      ! system temperature on A
     & (TSYSB,   DATA(294)),      ! system temperature on B
     & (AVERAGE, DATA(295)),      ! number of spectra averaged
     & (SCALEJY, DATA(296)),      ! JY to K conversion
     & (TRMS,    DATA(297)),      ! theoretical RMS noise in spectrum
     & (ZVLINDEX,DATA(298)),      ! array index of 0 Vlsr
     & (AITOKMS, DATA(299)),      ! array index to Km/s conversion
     & (RA50A,   DATA(300)),      ! ra  1950 of position A
     & (DC50A,   DATA(301)),      ! dec 1950 of position A
     & (RA50B,   DATA(302)),      ! ra  1950 of position B
     & (DC50B,   DATA(303)),      ! dec 1950 of position B
     & (ANTHA,   DATA(304)),      ! ha  at end of observation
     & (ANTDC,   DATA(305)),      ! dec at end of observation
     & (RABOFF,  DATA(306)),      ! ha  beam offset
     & (DCBOFF,  DATA(307)),      ! dec beam offset
     & (YSCALE,  DATA(308)),      ! y axis plot scale
     & (YOFSET,  DATA(309)),      ! y axis plot offset
     & (DTSYSA,  DATA(310)),      ! error in system temp. on A
     & (DTSYSB,  DATA(311)),      ! error in system temp. on B
     & (AIRTEMP, DATA(312)),      ! outside air temperature in deg C
     & (AIRHUM,  DATA(313)),      ! outside air humidity in %
     & (SUBFOCUS,DATA(314)),      ! subreflector focus position
     & (SUBTILT, DATA(315)),      ! subreflector tilt position
     & (TSYSR,   DATA(316)),      ! radiometer system temperature
     & (DTSYSR,  DATA(317)),      ! radiometer system temperature error
     & (TCALK,   DATA(318)),      ! cal noise diode temp in Kelvins
*
     & (DSYNONP,DDATA(160)),      ! synth freq on A (MHz)
     & (DSYNOFP,DDATA(161)),      ! synth freq on B (MHz)
     & (DFREQ,  DDATA(162)),      ! line rest freq  (MHz)
     & (DFOF,   DDATA(163)),      ! rf freq offset for A & B  (MHz)
     & (DFOFB,  DDATA(164)),      ! rf freq offset for B only (MHz)
     & (DXMC,   DDATA(165)),      ! l.o. multiplication factor
     & (DJP,    DDATA(166)),      ! julian data of start of obs
*
     & (ACOORD, IP(1)),           ! buffer for coordinate precession
     & (BCOORD, IP(3)),           ! by DPRC2
*
     & (ILOG, CLOG),              ! buffer for OBSLG log
*
     & (BUFFER,CBUFFER),          ! buffer for angle readout
*
     & (ANTBUF(1), ITYPE),        ! buffer for DRIVE
     & (ANTBUF(2), COORD1),
     & (ANTBUF(4), COORD2),
     & (ANTBUF(6), TRACK),
     & (ANTBUF(7), DRIVEWAIT)
*
*     I/O logical units are initialised in a block data statement
      INCLUDE COMMONLUS.SUB
*
      DATA  NSP /256/,                 ! no of points in spectrum
     &      N1 /1/,                    ! array index of first spectrum point
     &      N2 /256/,                  ! array index of last  spectrum point
     &      IW /0/,                    ! rectangular window - no smoothing
     &      IPOLY /1/,                 ! first order polynomial fitted
     &      DTR /0.017453293/,         ! degrees to radians
     &      VLIGHT /299792.5d0/,       ! velocity of light (km/s)
     &      ALAT /-25.88921d0/,        ! Hartrao geodetic lat (deg, S neg)
     &      OLONG /-27.68570d0/,       ! Hartrao geodetic long (deg, E neg)
     &      ELEV /1398.0d0/,           ! Hartrao elevation (meters)
     &      TUNIT /'K '/,              ! intensity unit
     &      FOLDED /.false./,          ! spectrum not folded
     &      DM6    /1.0D-6/,           ! 10^-6
C    &      XMC25  /480D0/,            ! 2.5 cm first LO multiplier
     &      IPB /1,256,18*0/,          ! polyfit blocks
     &      LU150 /57/,                ! HP150 logical unit
*
*           programs called by observing program
     &      ACFIN / 'ACFIN ' /, PRGNAM / 'SPECC ' /, DRIVE / 'DRIVE '/,
     &      SPPLO / 'SPPLO ' /, ALARM  / 'ALARM ' /, DPRC2 / 'DPRC2 '/,
     &      OBSLG / 'OBSLG ' /,
*
*     error messages for OBSLG
     &      STRMES   / 'Invalid runstring' /,
     &      SRCMES   / 'Invalid source file' /,
     &      STOPMES  / 'STOP in source file' /,
     &      READMES  / 'Cannot read source file' /,
     &      SETMES   / 'All sources set' /,
     &      RCVMES   / 'Receiver fault' /,
     &      B15MES   / 'Bit 15 set' /,
     &      WRTMES   / 'File write error' /,
*
*           program killer messages
*           these programs MUST be permanently loaded with DON'T CLONE
     &      OFFACFIN / 'OF,ACFIN,8'/,
     &      OFFDRIVE / 'OF,DRIVE,8'/,
*
*index :      1       2        3        4        5        6      7
     & RFMAX
     & / 13000.,  8500.,   7000.,   6200.,   5500.,   4000.,   2000./,
     & SYSTEM
     & / '2.5S', '3.6S',  '4.5S',  '  5S',  '  6S',  ' 13S',  ' 18S'/,
     & WAVE
     & /    2.5,    3.5,     4.5,     5.0,     6.0,    13.0,    18.0/,
     & RABM
     & / -0.405, +0.015,  -0.380,  -0.380,  +0.555,  +0.057,  +0.094/,
     & DECBM
     & / -0.050, -0.597,  -0.130,  -0.130,  -0.203,  +0.445,  +0.936/,
     & IXMC
     & /      2,      1,       2,       2,      16,       2,       2/,
     & STDLO
     & /754.0d0,230.0D0, 754.0d0, 752.0D0, 292.5d0,1056.0D0, 754.0d0/,
     & NDSEL
     & /      2,      1,       2,       2,       2,       4,       5/,
     & DNOISE
     & /  158.0,   10.0,    82.0,    68.0,    11.4,    3.96,    28.4/,
CCCC
CCCC   lu36 failed - put correlator  video signal on lu 35 channel 0
CCCC & IDVMSL    /    66b,    66b,     66B,     66b,     66b,     66b /,
     & IDVMSL
     & /    00b,    00B,     00b,     00B,     00b,     00b,     00b/,
     & ISYNTH
     & /   8662,   8662,    8662,    8662,    8662,    8662,    8662/,
     & STDFOCUS
     & /    8.0,    8.0,     8.0,     8.0,     8.0,     8.0,     5.0 /,
     & STDTILT
     & /  -0.67,  -0.67,   -0.67,   -0.67,   -0.67,   -0.67,   +9.70 /
*
*     start of program
*
*     pick up the run string parameters
      CALL RMPAR (IP)
*
*     allocate the standard print device
      CALL FSYSU (LU,LU)
*
*     initialize suspension checks
      PSUSPD1 = .FALSE.
      PSUSPD2 = .FALSE.
*
      WRITE (LU,'(A6,'' S reg bit 15: end''/
     &    17X,''14: next source''/
     &    17X,''13: suspend''/
     &    17X,''12: no SCHDL''/
     &    17X,''11: ZE at suspend or end''/
     &    17X,''10: new source or file''/)') PRGNAM
*
*     check validity of input parameters
      FAULT = .FALSE.
      IF (IP(1) .LT. 1 .OR. IP(1) .GT. 9999 .OR.
     &    IP(2) .LT. 1 .OR.
     &    IP(3) .LT. 0 .OR. IP(3) .GT. 1) THEN
          FAULT = .TRUE.
          CLOG(26:) = STRMES(1:)
          GO TO 990
      END IF
*
*     set up a large buffer for storing spectra to disc
      CALL LGBUF (LBUF,700)
*
*     create the source file name from run string parameter 1
      WRITE (DIGBUF(1:4),'(I4)',ERR=11,IOSTAT=IOS) IP(1)
   11 IF (IOS .NE. 0) THEN
          FAULT = .TRUE.
          CLOG(26:) = SRCMES(1:)
          GO TO 990
      END IF
*
*     write is right-justified, so find how many leading blanks
      ID1 = 1
      DO I = 1,4
          IF (DIGBUF(I:I) .EQ. ' ') ID1 = I + 1
      END DO
*     file name is SP followed by up to 4 digits, on CR 16
      SOURCEFILE = 'SP'//DIGBUF(ID1:4)//'::16'
*     start at source number NSOURCE in SOURCEFILE from run string parm 2
      NSOURCE = IP(2)
*
      IF (IP(3) .EQ. 0) THEN
*         program has been SCHDL'd
*         set word for clearing bits 15, 14, 13, 11, 10 at start of obs
          IBITCLEAR = 11777B
          INTERRUPTIBLE = .FALSE.
*         set bit 12 of the switch register
          CALL SWOUT (10000B)
          PRINT *,'No SCHDL'
      ELSE
*         interruptible by SCHDL
*         set word for clearing bits 15,14,13,12,11,10 at start of obs
          IBITCLEAR = 1777B
          INTERRUPTIBLE = .TRUE.
          PRINT *,'Can run SCHDL'
      END IF
*
*     these programs MUST be permanently LOADed with DON'T CLONE
*     destroy memory resident ACFIN and DRIVE, in case of previous abort
      CALL MESSS (OFFACFIN,10)
      CALL MESSS (OFFDRIVE,10)
*
      FAULT = .FALSE.
      NEWSOURCE = .FALSE.
*     set number of sources attempted below west horizon
      NOTUP = 0
*     preset number of last source in source file to large number
      LASTSOURCE = 1000
*     tell FILERD to execute WAITs that it reads (FALSE in SPRED)
      DOWAIT = .TRUE.
*     read last observation number used from file SPLAST::15
      CALL SPLAST (.TRUE.,IOBSERVATION)
*     and increment it by one
      IOBSERVATION = IOBSERVATION + 1
*
*     restart here if new source file or non-sequential source
*     --------------------------------------------------------
   30 NREADERRORS = 0
      IFIRST = IOBSERVATION
*
*     read from source file : restart here if bit 14 set or next source due
*     ---------------------------------------------------------------------
  100 IPLOT  = 2
      ADAV   = 0.0
*
      CALL FILERD (SOURCEFILE, NSOURCE, DOWAIT,
     &    FILE_ERROR, READ_ERROR, FILE_END, IEND,
     &    NAME, KTYPE, NACC, NOBS, KOUNT, BW, SYNOFS, SYNRF,
     &    COORD1, COORD2, RAREF, DECREF, DFREQ, OUTFILE)
*
      IF (IEND .GT. 0) THEN
*         STOP or ZENITH command was read in the source file - shut down
          CLOG(26:) = STOPMES(1:)
          GO TO 960
      END IF
*
      IF (FILE_ERROR) THEN
*         fatal error - cannot read source file - put alarm on and stop
          FAULT = .TRUE.
          CLOG(26:) = READMES(1:)
          GO TO 990
      END IF
*
      IF (READ_ERROR) THEN
          NREADERRORS = NREADERRORS + 1
          IF (NREADERRORS .LT. 10) THEN
              PRINT 1110
 1110         FORMAT ('Try next source')
              NSOURCE = NSOURCE + 1
              GO TO 100
          ELSE
*             fatal error - cannot read source file - put alarm on and stop
              FAULT = .TRUE.
              CLOG(26:) = READMES(1:)
              GO TO 960
          END IF
      END IF
*
      IF (FILE_END) THEN
          LASTSOURCE = NSOURCE - 1
          NSOURCE = 1
          GO TO 100
      END IF
*
      CALL UPCASE (KTYPE)
*     correlator count
      COUNT = KOUNT + 1
*
*     find frequency index for selecting system in use
      DO I = 1, NSYS
          IF (DFREQ .LT. RFMAX(I)) INDEX = I
      END DO
*
      IF (WAVE(INDEX) .EQ. 18.0 .AND. IOBSERVATION .EQ. IFIRST) THEN
*         get hyperbola tilt and focus
          CALL RHYP (SUBFOCUS, SUBTILT)
          IF (ABS(SUBTILT+0.67) .LT. 0.1) THEN
*             subreflector assumed to be untilted for 18, convert to 18U
              SYSTEM(INDEX) = ' 18U'
              STDFOCUS(INDEX) = 8.0
              STDTILT(INDEX) = -0.67
*             pick up HA and DEC beam offsets from SYPARM
          END IF
      END IF
*
*     pick up system parameters from SYPARM::16
      CALL RDSYS (INDEX,SYSTEM,RABM,DECBM,DNOISE)
*
*     save calibration noise diode temperature in housekeeping
      TCALK = DNOISE(INDEX)
*
*     check 18cm polarization
      IF (WAVE(INDEX) .EQ. 18) THEN
          IF (TCALK .EQ. 6.2) THEN
              POL18CM = 'LCP'
          ELSE IF (TCALK .EQ. 5.3) THEN
              POL18CM = 'RCP'
          ELSE
              POL18CM = 'UNKNOWN'
          END IF
          PRINT *,'18cm CalK from SYPARM=',TCALK,'K ie POL=',POL18CM
      END IF
*
*     check whether more than one LO is in use for this system
      IF (WAVE(INDEX) .EQ. 2.5) THEN
*         DRO installed 1997 04 29 10510MHz, was 10560 MHz
          FIRSTLO = 10510D0
      ELSE IF (WAVE(INDEX) .EQ. 3.5) THEN
          FIRSTLO = 8080D0
      ELSE IF (WAVE(INDEX) .EQ. 4.5) THEN
          FIRSTLO = 5000D0
      ELSE IF (WAVE(INDEX) .EQ. 5.0) THEN
          FIRSTLO = 4370D0
      ELSE
          FIRSTLO = 0D0
      END IF
c
*     set up coordinates
*     ------------------
      IF (KTYPE .EQ. 'CE') THEN
*         1950 celestial coordinates
          RA50A = COORD1
          DC50A = COORD2
          IF (DC50A .GT. 180.0) DC50A = DC50A - 360.0
      ELSE IF (KTYPE .EQ. 'GA') THEN
*         convert galactic coordinates to 1950 celestial
          CALL CTOG (2,RA50A,DC50A,COORD1,COORD2)
      ELSE
          PRINT *,'coord type ',KTYPE,' ?'
          PRINT 1110
          NSOURCE = NSOURCE + 1
          GO TO 100
      END IF
*
*     find mode : position (PS) or frequency (FS) switching
      MODE = 'FS'
      IF (INT(SYNRF) .EQ. 0) MODE = 'PS'
*
*     precess on-source coordinates
*     aonra, aondec are precessed source coordinates
*     onra,  ondec  are precessed source coords with beam offsets added.
      ACOORD = RA50A
      BCOORD = DC50A
      CALL EXEC (9,DPRC2,IP(1),IP(2),IP(3),IP(4))
      CALL RMPAR(IP)
      AONRA = ACOORD
      AONDEC = BCOORD
      RABOFF = RABM(INDEX)
      DCBOFF = DECBM(INDEX)
      ONRA = ACOORD + RABOFF/COS(AONDEC*DTR)
      ONDEC = BCOORD + DCBOFF
*
*     precess off-source coordinates
      RA50B = RA50A + RAREF
      DC50B = DC50A + DECREF
      ACOORD = RA50B
      BCOORD = DC50B
      CALL EXEC (9,DPRC2,IP(1),IP(2),IP(3),IP(4))
      CALL RMPAR(IP)
      OFFRA = ACOORD + RABOFF/COS(BCOORD*DTR)
      OFFDEC = BCOORD + DCBOFF
*
*     find command hour angle, limit to -180 < comha < +180
      COMHA = HACOM(OFFRA)
*
*     on-source integration time
      TINT = 52.5 * 5.12/BW * COUNT/16384.0 * NACC
*     observation time in minutes, approximately
      OBSTIME = (TINT * 2 + 90) / 60
*
*     check western horizon limit
      IF (WESTLIM(OFFRA,OFFDEC,ONRA,ONDEC,TINT)) THEN
          PRINT 1820, NAME, NSOURCE
 1820     FORMAT (A,' = source',I3,' has set.')
          NSOURCE = NSOURCE + 1
          NOTUP = NOTUP + 1
          IF (NOTUP .LT. LASTSOURCE * 2) THEN
*             try next source
              GO TO 100
          ELSE
*             program has checked all sources at least once
C             PRINT *,'All sources set'
              CLOG(26:) = SETMES(1:)
              GO TO 960
          END IF
      END IF
*
*     allocate & set RN, write observing info to disc file for SCHDL
      IF (INTERRUPTIBLE .AND. IOBSERVATION .EQ. IFIRST) THEN
          CALL RNALC (PRGNAM, WAVE, INDEX, IRN)
      END IF
*
*     create log buffer and send to OBSLG
      CALL TIMESTAMP (ITIME,IY,PRGNAM,CLOG)
      WRITE (CLOG(26:),1831,ERR=1832) SOURCEFILE, NSOURCE, NAME
 1831 FORMAT ('File ',A,' Source',I3,': ',A)
 1832 CALL EXEC (24,OBSLG,1,0,0,0,0,ILOG,38)
C
C     PRINT 1840, SOURCEFILE, NSOURCE, NAME, OUTFILE
C    &            bw, kount, dfreq, synofs, synrf,
C    &            dnoise(index), wave(index),
C    &            rabm(index), decbm(index)
C1840 FORMAT ( 'File ',A,' Source',i3,': ',A,' outfile: ',A10)
C    &         70'='/
C    *         'correlator bandwidth =',f6.2,' MHz, '
C    *         'thumbwheel count =',@8/
C    *         'line rest frequency =',f14.6,' MHz, '/
C    *         'synthesizer offset applied to A & B  =',spf12.1,' Hz'/
C    *         'synthesizer offset applied to B only =',spf12.1,' Hz'/
C    *         'noise cal. =',ssf7.1,'K at',ssf6.1,'cm'/
C    *         'beam offsets from SYPARM::16 : RA',
C    *         spf7.3,'  DEC',spf7.3,' deg')
C
C     PRINT 1842, RAREF, DECREF
c1842 FORMAT ('pos. offset for B : RA',spf7.3,'  DEC',spf7.3,' deg')
*
C     PRINT 1844,GLII,GBII,RA50A,DC50A,COMHA,OFFDEC
C1844 FORMAT( 3X,'LII',5X,'BII',4X,'1950 RA',4X,'DEC',4X,'COMMAND HA',
C    &        3X,'DEC',
C    &       /2F8.3,2X,2F8.3,4X,2F8.3)
*
C     WRITE (LU,1846) NOBS, OBSTIME / 60
c1846 FORMAT (i4,' observations each of',f5.1,' minutes')
*
*     check eastern horizon limit
      IF (COMHA .LT. HALIM(-90.0,OFFDEC)) THEN
*         source below east horizon , wait until it has risen
          MWAIT =  (COMHA - HALIM(-90.0,OFFDEC)) * 4
          PRINT *,'Source has not risen; ',
     &            'wait ',-MWAIT,' mins.'
*
          IF (MWAIT .LE. -1) CALL EXEC (12,0,3,0,MWAIT)
      END IF
*
*     start of position B observing loop procedures
*     ---------------------------------------------
*     clear switch register bits 15,14,13,11 and 12 if interruptible
*     retain values of other bits
  200 ISWIT = SWIN(0)
      ISWIT = ISWIT .AND. IBITCLEAR
      CALL SWOUT (ISWIT)
*
*     reset the "computer failed" alarm
      CALL OBSOK
*
*     check the subreflector focus and tilt, print warning if wrong
      CALL CHKHYP (INDEX,STDFOCUS,STDTILT,SUBFOCUS,SUBTILT,FAULT)
*
*     store the start time (UT & Julian) of the previous observation
      IS = ITIME(2)
      IM = ITIME(3)
      IH = ITIME(4)
      ID = ITIME(5)
      DJP = DJ
*
*     calculate synthesizer frequency offset in MHz
      DXMC = IXMC(INDEX)
      DFOF = SYNOFS * DM6 * DXMC
      DFOFB= SYNRF  * DM6 * DXMC
*     array index to km/s conversion
      DBW = BW
      AITOKMS = DBW / NSP * VLIGHT / DFREQ
*     zero velocity array index
      ZVLINDEX = NSP * (0.5D0 + DFOF / DBW) + 1
*
*     store previous values of synthesizer settings
      DSYNOFP = DSYNOF
      DSYNONP = DSYNON
*
*     obtain vlsr for given coordinates, at hartebeesthoek
      CALL TIMESTAMP (ITIME, IY, PRGNAM, CLOG)
      CALL DOP (DBLE(AONRA*DTR),DBLE(AONDEC*DTR),
     &          IY-1900,ITIME(5),ITIME(4),ITIME(3),
     &          ITIME(2)+INT(TINT*0.5),
     &          ALAT,OLONG,ELEV,VLSROF)
*
      CALL DOP (DBLE(AONRA*DTR),DBLE(AONDEC*DTR),
     &          IY-1900,ITIME(5),ITIME(4),ITIME(3),
     &          ITIME(2)+INT(TINT*1.5),
     &          ALAT,OLONG,ELEV,VLSRON)
*
*     relativistic doppler shift frequency correction
      RELCOR = VLSROF / VLIGHT
      DOPFREQOF = DFREQ * DSQRT ((1D0 - RELCOR) / (1D0 + RELCOR))
      RELCOR = VLSRON / VLIGHT
      DOPFREQON = DFREQ * DSQRT ((1D0 - RELCOR) / (1D0 + RELCOR))
*
*     for lower sideband at 160 MHz mixer the L O frequency is :
*     line frequency - (I F center frequency - 0.5 * correlator bandwidth)
*     The synthesizer frequency is the  L O freq / muliplication factor
c
      VSYNOF = (DOPFREQOF - FIRSTLO - 160 + DBW/2) / DXMC
      VSYNON = (DOPFREQON - FIRSTLO - 160 + DBW/2) / DXMC
c     sign for adding users offsets for positions A and B
      LOSIGN = +1
c
c     add in users offsets for position B and A
      DSYNOF = VSYNOF + LOSIGN * (SYNOFS + SYNRF) * DM6
      DSYNON = VSYNON + LOSIGN * SYNOFS * DM6
*
*     start of position B observation
*     -------------------------------
*     set synthesizer for LO
      CALL SETLO (ISYNTH, INDEX, DSYNOF)
*
      IF (IOBSERVATION .EQ. IFIRST) THEN
*         check the LO control, measure the system temperature
          PRINT *,'System check:'
          CHECKVID = .TRUE.
          CALL CALT (IDVMSL,NDSEL,DNOISE,ISYNTH,INDEX,DSYNOF,5,
     &               PRGNAM,CLOG,ILOG,OBSLG,CHECKVID,
     &               TDUM,DTDUM,TRDUM,DTRDUM,FAULT)
*         if problem setting local oscillator, put on alarm & shut down
          IF (.NOT. FAULT) THEN
              PRINT *,'Tvid=',TDUM,'+-',DTDUM
c    &                ' Trad=',TRDUM,'+-',DTRDUM,'K'
          ELSE
              CLOG(26:) = RCVMES(1:)
              GO TO 960
          END IF
      END IF
*
*     track position B current (precessed) coordinates
      ITYPE = 4
      COORD1 = OFFRA
      COORD2 = OFFDEC
      TRACK = .TRUE.
      DRIVEWAIT = .TRUE.
      CALL EXEC (9,DRIVE,0,0,0,0,0,ANTBUF,7)
*     second call to allow for disasters
      CALL EXEC (9,DRIVE,0,0,0,0,0,ANTBUF,7)
*
*     create log buffer and send to OBSLG
      CALL TIMESTAMP (ITIME,IY,PRGNAM,CLOG)
*     get Julian date for housekeeping
      CALL JD (IY, ITIME, DJ)
*     log message
      WRITE (CLOG(26:),2102,ERR=2103)
     &        IOBSERVATION, OBSTIME, OUTFILE(1:10)
 2102 FORMAT ('Obs ',I6,' for ',F4.1,' mins, to ',A)
 2103 CALL EXEC (24,OBSLG,1,0,0,0,0,ILOG,38)
*
C     PRINT 2100, iobservation,iy,(itime(j), j = 5,3,-1),obstime
C2100 format('Spectrum',i6,' starts at ',4i4,' UT for ',f5.1,' minutes')
C     PRINT 2300,'Vlsr=',VLSR,' Fdop=', DOPFREQ,' Fsyn=',VSYN
C2300 FORMAT (3X,A,F12.9,A,F16.9,A,F16.9)
C     PRINT 2400, DSYNOF
C2400 FORMAT (3x,'L.O. Synthesizer setting:',f11.6,' MHz ')
*!!!
*     start the correlator program
      CALL EXEC (10,ACFIN,NSP,NACC,KOUNT,LU,0)
*     if continuing on the present source,
*     then store the previous spectrum on disc, and plot it
      IF (NEXTOP .EQ. 1) GO TO 500
*
*     collect position B spectrum and store it.
  250 CALL EXEC (23,ACFIN)
      CALL EXEC (14,1,REF,512)
*
*     start of position A observation
*     -------------------------------
*     print synthesizer setting, track on-source coordinates.
C     IF (MODE .EQ. 'FS') WRITE (LU,2400) DSYNON
*
      CALL SETLO (ISYNTH,INDEX,DSYNON)
*
*     track the A position coordinates
      ITYPE = 4
      COORD1 = ONRA
      COORD2 = ONDEC
      TRACK = .TRUE.
      DRIVEWAIT = .TRUE.
      CALL EXEC (9,DRIVE,0,0,0,0,0,ANTBUF,7)
*     second call to allow for disasters
      CALL EXEC (9,DRIVE,0,0,0,0,0,ANTBUF,7)
*
*     measure the outside air temperature and humidity
CCCCC commented out - on lu 36
CCCCC CALL RTHUM (AIRTEMP, AIRHUM)
*
*     measure the system temperature
      CHECKVID = .FALSE.
      CALL CALT (IDVMSL,NDSEL,DNOISE,ISYNTH,INDEX,DSYNON,30,
     &           PRGNAM,CLOG,ILOG,OBSLG,CHECKVID,
     &           TSONA,DTSONA,TSYSR,DTSYSR,FAULT)
*
*     at present calibrated only at position A, so
      TSONB = TSONA
      DTSONB = DTSONA
*
*     if unable to calibrate in 30 tries, put on alarm and shut down
      IF (FAULT) THEN
          CLOG(26:) = RCVMES(1:)
          GO TO 960
      END IF
*
C     PRINT *,'  Air temp.=',AIRTEMP,'C humidity =',AIRHUM,'%_'
*
*     start correlator program, get spectrum on completion
      CALL EXEC (10,ACFIN,NSP,NACC,KOUNT,LU,0)
      CALL EXEC (23,ACFIN)
      CALL EXEC (14,1,DIFF,512)
*
*     obtain difference spectrum and normalise to kelvins
      IF (MODE .EQ. 'PS') THEN
*         for position switching :
          DO I = 1,NSP
*             assum no signal anywhere in the reference spectrum
              DIFF(I) = (DIFF(I)/REF(I) - 1.0) * TSONA
          END DO
      ELSE IF (MODE .EQ. 'FS') THEN
*         for frequency switching :
*         assume signal is in left half of DIFF, right half of REF
          DO I = 1,NSP/2
*             left half of spectrum
              DIFF(I) = (DIFF(I)/REF(I) - 1.0) * TSONA
*             right half of spectrum
              J = I + NSP/2
              DIFF(J) = (1.0 - REF(J)/DIFF(J)) * TSONB
          END DO
      END IF
*
*     to cope with funnies force first point in spectrum = second point
      DIFF(1) = DIFF(2)
*
*     check termination options at end of off and on source runs
*     ----------------------------------------------------------
*     increment run number, assume continuing with next observation
      IOBSERVATION = IOBSERVATION + 1
      IF (IOBSERVATION .EQ. 32766) THEN
          IOBSERVATION = 1
          IFIRST = 0
      END IF
      NEXTOP = 1
*
*     read antenna ha and dec via dio
  360 CALL EXEC (1,11,BUFFER,6,1,3)
*     mask out tach sign and magnitude bits for ha, then dec
      BUFFER(1) = BUFFER(1) .AND. 171777B
      BUFFER(4) = BUFFER(4) .AND. 171777B
      READ (CBUFFER,'(2F6.3)',ERR=360) ANTHA,ANTDC
      IF (ANTDC .GT. 180.0) ANTDC = ANTDC - 360.0
c     WRITE (LU,3600) ANTHA,ANTDC
c3600 FORMAT (' end HA ',f7.3,' DEC ',f7.3)
*
*     check if horizon reached during next observation
      IF (WESTLIM(OFFRA,OFFDEC,ONRA,ONDEC,TINT)) THEN
          PRINT 1820, NAME, NSOURCE
*         go to next source
          NEXTOP = 2
      END IF
*
*     check bit 14 and if number of obs on current source done
      IF (ISSW(14) .LT. 0 .OR. NOBS .EQ. (NINT(ADAV) + 1)) NEXTOP = 2
      IF (ISSW(10) .LT. 0) THEN
*         set option for new file/source
          NEXTOP = 2
          NEWSOURCE = .TRUE.
      END IF
*
*     check bit 15 for end, over-rides previous options
      IF (ISSW(15) .LT. 0) THEN
          NEXTOP = 3
          CLOG(26:) = B15MES(1:)
C         PRINT 1100
C1100     FORMAT ('bit 15 set')
      END IF
*
*     set standard lo frequency before suspension check
      IF (WAVE(INDEX) .EQ. 18.0) THEN
*         for 1666 MHz filter
          STDLO(INDEX) = 754D0
*         for 1720 MHz filter
          IF (DFREQ .GT. 1700D0) STDLO(INDEX) = 781D0
*         for 1612 MHz filter
          IF (DFREQ .LT. 1630D0) STDLO(INDEX) = 727D0
      END IF
      CALL SETLO (ISYNTH,INDEX,STDLO(INDEX))
*
      IF (INTERRUPTIBLE) THEN
*         clear RN to allow scheduled program to break in
          CALL RNCLW (PRGNAM, IRN, PSUSPD1)
*         check if bit 13 has been set
          CALL SUSPD (PRGNAM, IRN, NREC, PSUSPD2)
      END IF
*
*     tests if program was interrupted, check configuration
      IF (INTERRUPTIBLE .AND. (PSUSPD1 .OR. PSUSPD2)) THEN
*
*         pause to let user set bit 15 if wanted
          CALL EXEC (12,0,2,0,-5)
*
*         reset synthesizers
          CALL SETLO (ISYNTH, INDEX, DSYNOF)
C         now DRO on 2.5
C         IF (WAVE(INDEX) .EQ. 2.5) THEN
C             set first lo for 2.5 cm
C         END IF
*
*         check bit 15
          IF (ISSW(15) .LT. 0) THEN
              NEXTOP = 3
              CLOG(26:) = B15MES(1:)
C             PRINT 1100
          ELSE
*             restarting - check out the system
*             check the subreflector focus and tilt, print warning if wrong
              CALL CHKHYP (INDEX,STDFOCUS,STDTILT,SUBFOCUS,SUBTILT,
     &                     FAULT)
*             check synthesizer control and calibration
              CHECKVID = .TRUE.
              CALL CALT (IDVMSL,NDSEL,DNOISE,ISYNTH,INDEX,DSYNOF,20,
     &                   PRGNAM,CLOG,ILOG,OBSLG,CHECKVID,
     &                   TDUM,DTDUM,TRDUM,DTRDUM,FAULT)
*             if unable to calibrate in 20 tries, put alarm on and stop
              IF (FAULT) THEN
                  CLOG(26:) = RCVMES(1:)
                  GO TO 960
              END IF
          END IF
*
*         if continuing with this source then
          IF (NEXTOP .EQ. 1 .AND.
*             check if source has set during the interruption
     &        WESTLIM (OFFRA,OFFDEC,ONRA,ONDEC,TINT)) THEN
              PRINT 1820, NAME, NSOURCE
              NEXTOP = 2
          END IF
      END IF
*
*     continue with next observation on this source if nextop not reset
      IF (NEXTOP .EQ. 1) GO TO 200
*
*     else store time, synth freqs for last spectrum plot
      IS = ITIME(2)
      IM = ITIME(3)
      IH = ITIME(4)
      ID = ITIME(5)
      DJP = DJ
      DSYNONP = DSYNON
      DSYNOFP = DSYNOF
*
*     store spectrum in disc file then plot it
*     ----------------------------------------
*     store the spectrum for transfer to SPPLO
  500 DO I = 1,NSP
          DATA(I) = DIFF(I)
      END DO
*     remove slope from spectrum
      CALL RMV (NSP,DATA)
*     store more housekeeping in DATA
      IOBS1 = IOBSERVATION - 1
      TSYSA = TSONA
      DTSYSA = DTSONA
      TSYSB = TSONB
      DTSYSB = DTSONB
      AVERAGE = 1.0
*     write spectrum and housekeeping to disc file
      CALL WRTSPF (OUTFILE,IDATA,IOUTREC,FAULT)
*
*     put on alarm and shut down if unable to write spectra to disc
      IF (FAULT) THEN
          CLOG(26:) = WRTMES(1:)
          GO TO 990
      END IF
*
*     write the number of the last successful observation to disc file
      CALL SPLAST (.FALSE.,IOBS1)
*
*     individual spectrum plot
*     ------------------------
*     set individual plot type
      IPLOT = 2
*
*     set up plotter control for HP150, call plotter program
*     parameter 1 = lu150 = lu 57
*     parameter 2 = 1  with hard copy (0 for none)
*     parameter 3 = 2  individual spectrum
      CALL EXEC (24,SPPLO,LU150,1,IPLOT,0,0,IDATA,700)
*
      IF (NOBS .GT. 1) THEN
*         include spectrum in average and plot it
          DO I = 1,NSP
              AVRG(I) = (AVRG(I) * ADAV + DIFF(I)) / (ADAV + 1.0)
          END DO
          ADAV = ADAV + 1.0
          AVERAGE = ADAV
*
*         remove slope on average spectrum
          CALL RMV (NSP,AVRG)
*         plot type for average spectrum plot
          IPLOT = 3
*         store average array for data transfer
          DO I = 1,NSP
              DATA(I) = AVRG(I)
          END DO
*         plot average spectrum, no hard copy
          CALL EXEC (24,SPPLO,LU150,0,IPLOT,0,0,IDATA,700)
      END IF
      IF (NEXTOP .EQ. 1) GO TO 250
*
*     start new source or terminate (nextop = 2 or 3)
*     -----------------------------------------------
      IF (NEXTOP .EQ. 2) THEN
*         update parameters for new source
          NSOURCE = NSOURCE + 1
          IF (NEWSOURCE) THEN
*             start new file / source
              PRINT *,'Now at source ',NSOURCE,' in file ',SOURCEFILE
              NEWSOURCE = .FALSE.
*
  930         PRINT *,'Source file name ? _'
              READ '(A)', SOURCEFILE
              ICHAR = NCHAR (SOURCEFILE)
              IF (ICHAR .LE. 2) GO TO 930
*
              PRINT *,SOURCEFILE(1:ICHAR),'Start at source No. ? _'
              READ  *,NSOURCE
              GO TO 30
          ELSE
*             restart on next source
              GO TO 100
          END IF
      END IF
*
*     else nextop = 3 so park telescope and end
*     -----------------------------------------
  960 IF (ISSW(11) .LT. 0 .OR. IEND .EQ. 2) THEN
*         bit 11 is set so park the antenna at zenith
          ITYPE = 2
          COORD1 = 0.0
          COORD2 = 334.114
          TRACK = .FALSE.
          DRIVEWAIT = .FALSE.
          CALL EXEC (9,DRIVE,0,0,0,0,0,ANTBUF,7)
      END IF
*
  990 IF (FAULT) CALL EXEC (10,ALARM)
c     send message to OBSLG
      CALL TIMESTAMP (ITIME,IY,PRGNAM,CLOG)
      CALL EXEC (24,OBSLG,1,0,0,0,0,ILOG,38)
C     clear switch register
      CALL ISSR(0)
      END
****************
      BLOCK DATA
****************
      INCLUDE COMMONLUS.SUB
*
      DATA LU /7/, LU3336 /33/, LU8662 /38/, LU8840A /35/
      END
**************************
      SUBROUTINE TIMESTAMP (ITIME, IY, PRGNAM, CLOG)
**************************
*     get time, stamp buffer with time and program name
*
      INTEGER*2 ITIME(5),     ! output time in ms, s, m, h, d
     &          IY            ! output year
      CHARACTER PRGNAM*(*),   ! input program name
     &          CLOG*(*)      ! output OBSLG buffer time stamped
*
      CALL EXEC (11,ITIME,IY)
      WRITE (CLOG(1:25),1000,ERR=1001)
     &      IY,(ITIME(I),I=5,2,-1), PRGNAM
 1000 FORMAT (2I4,3I3,' ',A6,' ')
 1001 RETURN
      END
*****************************
*     include subroutines from /MIKE/PROGS/ on control computer
*
      INCLUDE ACSK.SUB       ! scheduling subs permitting interruption
      INCLUDE ACSUF.SUB      ! spectral line subroutines
      INCLUDE ERFIL.SUB      ! error messages for disc file i/o
      INCLUDE F8662SP.SUB    ! set hp8662 frequency, with diagnostics
      INCLUDE HALIM.SUB      ! ha limits
      INCLUDE JD.SUB         ! julian date
      INCLUDE NCHAR.SUB      ! number of characters in string
      INCLUDE OBSOK.SUB      ! observing alarm okay reset
CCCC  INCLUDE POL18.SUB      ! read 18 cm polarization via DIO removed SPECA
      INCLUDE RDSYS.SUB      ! read system parameters from SYPARM::16
      INCLUDE RHYP.SUB       ! read hyperbola tilt and focus
CCCC  INCLUDE RTHUM.SUB      ! read temp and humidity via 8840 lu 36
CCCC  INCLUDE SPCAL3536.SUB  ! calibration subroutines for lu 35 + 36
      INCLUDE SPCAL35.SUB    ! calibration subroutines for lu 35 only
      INCLUDE SPDF3.SUB      ! read source file on disc
      INCLUDE SPLAST.SUB     ! read / write last obs no. to disc
      INCLUDE UPCASE.SUB     ! convert lower case chars to upper
      INCLUDE VIDLEV.SUB     ! check video level during calibration
      INCLUDE WRTSPF.SUB     ! write spectra to disc file
*************************
