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 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