FTN77,S $FILES 0,2 PROGRAM TNSTP (3,80) *************************** * * PROGRAM TO STEP AROUND ALL BEAMS IN DEC AND RA * to compile: * FTN7X &TNSTP::16 0 - * to load: * LOADR:IH * OP,RPEBSS * FM,DC * RE,%TNSTP::16 * EN * * WRITTEN BY DCB 1982/04/30 * COPY OF TONOF AT 1984/09/27 D271 * Added 40 mdeg to all RAOFS on 1985/08/01 D213 * New feed positions 1985/08/07. Changed RAOFS DEOFS D 232 * Use of Fluke 8840 DVM 1985/10/24 * Writing ST to file hkeeping from D195/86 ie 14/7/86 * Change to meas of CE at end of 1st beam, instead of 2nd D205/86 * 3.6 and 6 cm DEOFS changed 1986/08/29 d241 * 3.6 cm new feeds and offsets D349/1986 15 12 86 * 6 cm DEOFS changed from -.556 to -.552 2 7 87 d183 * NB New feed positions for 6 1nd 3.6 cm as from 21-05-88, day 141 * Changed TUFLUX at 18 cm from 140 JY per DVM unit to 403 1992D336 * NEW FEED OFFSETS 13S, 18S, 6D 3.6D AS OF 29 MAR 1990 * 18S,6D & 3.6D UPDATED 1990 OCT 31 * ALL UPDATED 10/7/91 * output "end of source file return to No.1" commented out 19/10/95 MG * last revised <990510.1213> ********************************************************************* * CHARACTER CPLACE(21)*2, NAMRFL*10 * LOGICAL AOK, START, CHK, HKEEP, PROB, NEXT, FIRE, * RPTFQ, DUALBM, WVTB, CALSRS, IFBRK, NO3P4, * BELOW, FIRST * INTEGER ITIME(5), IPRAM(5), FILNAM(3), SWIN, DPRC2(3), * FDCB(144), SORSBF(40), SORSNM(5), IANG(5), * RESFIL(3), IDCB(272), IDUMY(2), ERSORS(10), IAB(2), * timeon(5) * REAL FNOFS(5), HPOFS(5), * RAOFS(5), DEOFS(5), WAVE(5), TUFLUX(5), * BMSEP(5), ERWAV(10), ERSQAV(10), MEDTB, MEDVM, * SFLUX(21), SERR(21), DVM(21) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * EQUIVALENCE (REG,IAB(1)), * (RAP, IANG(1)), (DECP, IANG(3)) * * FNOFS is the angular offset of beam FIRST NULLS. * HPOFS " " " " " " HALF POWER points. * FNOFS and HPOFS are measured from the beam peak. * RAOFS, DEOFS are the offsets of the FEEDS. * Measured to beam peak (single beam) or to cross-over (dual) * BMSEP is the angular separation (peak to peak) of dual beams * * TUFLUX is the NOISE TUBE equivalent flux in Jansky. * * ISIZE, ITYPE, ISECU, ICR refer to the RESULTS FILE. * Results are written on to RESFIL which has form BSday. * * HALIM is the Hour Angle limit for acceptable data * DATA WAVE / 6.2, 3.4, 13.0, 18.0, 6.1 /, * FNOFS / 0.18, 0.115, 0.393, 0.559, 0.18 /, * HPOFS / 0.082, 0.048, 0.166, 0.232, 0.082 /, * RAOFS / 0.011, 0.110, 0.051, 0.074, 0.011 /, * DEOFS / -0.251, -0.588, 0.426, 0.904, -0.251 /, * BMSEP / 0.254, 0.254, 0.0, 0.0, 0.0 /, * TUFLUX/ 24.0, 175.0, 35.0, 403.0, 200.0 /, * NFRQ / 5 /, * ISIZE / 5 /, ITYPE / 3 /, ISECU / 0 /, ICR / 15 /, * RESFIL / 2HBS, 2H00, 2H /, * HALIM / 5.4 /, * CHK / .FALSE. /, LU / 7 /, * DPRC2 / 2HDP, 2HRC, 2H2 / * * Initialise resources * CALL FSYSU (LU, LU) CALL ISSR (0) ! Reset S-register PRINT '(A1)', CHAR(14B) ! Form feed * * Set to zero the counter of the number of completed tracks. * KERR counts if largest no. out of DVM exceeds limit s.t. * program gives only 5 significant figures (2exp23-1)*10 NUMTRK = 0 NSETS = 0 KERR = 0 RPTFQ = .FALSE. IDCBS = 256 * * Ensure all Noise Diodes are off so calibration works * CALL EXEC (2, 113B, 0, 1, 3, 3) * * Print suitable Program Header * CALL EXEC(11,ITIME,IYEAR) WRITE (LU,1000) ITIME(5),IYEAR 1000 FORMAT(//3X,"ON/OFF TRACKING PROGRAM (TNSTP) : DAY ",I3,",",I4/ * 3X,38"="// * 3X,"THIS VERSION STEPS AROUND ALL BEAMS",// * 3X," Source file must use 1950.0 coordinates. ", * //3X," Set S register bit 0 ON to suspend 3.4 cm readings" * /22X," 1 ON to suspend 6.2 cm readings, ie DUAL FEEDS" * /22X," 2 ON to suspend 13.0cm readings" * /22X," 3 ON to suspend 18.0cm readings" * /22X," 4 ON to suspend 6.1 cm readings, ie SINGLE FEED" * //22X," 9 ON to repeat current FREQ." * /22X," 10 ON to repeat current SOURCE " * //22X," 13 ON to SUSPEND the program" * /22X," 14 ON to SKIP the next source " * /22X," 15 ON to END PROGRAM." /) * CALL BITST !Choose operating freqs,set S-reg CALL RNALC(IRN) ! Allow scheduling ** inserted by CF 5/88 * * Obtain the UNIVERSAL TIMES of Sunrise and Sunset and convert * to decimal. * CALL SUNTM (ITIME(5), IHSET, MSET, IHRIS, MRIS, * RASUN, DECSUN, *900,k) SUNSET = FLOAT(IHSET) + (FLOAT(MSET)/60.) SUNRIS = FLOAT(IHRIS) + (FLOAT(MRIS)/60.) * WRITE (LU,1250) SUNSET, SUNRIS 1250 FORMAT(" UT of sunset and sunrise in DECIMAL hrs : ",2F6.2) * * Subtract half hour from sunrise time so that END of measure * is before sunrise. SUNRIS = SUNRIS - 0.2 * * Convert to seconds. SUNRIS = SUNRIS * 3600. SUNSET = SUNSET * 3600. * * Decide whether checking BEAM PARAMETERS. WRITE (LU,2100) 2100 FORMAT(/3X," Necessary to check BEAM PARAMETERS? Yes(T) _") * READ (LU,1080) CHK * IF ( .NOT. CHK ) GO TO 140 * * CHECK THE BEAM PARAMETERS FOR EACH FREQUENCY * -------------------------------------------- DO 130 I=1,NFRQ * * Bits 0,1,2,3,4 set for skip 3.4,6.2,13.0,18.0,6.1 cm. measurements ISWIT = SWIN(0) ISWIT = ISWIT .AND. 000037B GO TO (132, 131, 133, 134, 135) I * 131 ISWIT = ISWIT .AND. 1B IF ( ISWIT .EQ. 1B ) GO TO 130 GO TO 139 132 ISWIT = ISWIT .AND. 3B IF ( ISWIT .GE. 2B ) GO TO 130 GO TO 139 133 ISWIT = ISWIT .AND. 7B IF ( ISWIT .GE. 4B ) GO TO 130 GO TO 139 134 ISWIT = ISWIT .AND. 17B IF ( ISWIT .GE. 10B) GO TO 130 GO TO 139 135 ISWIT = ISWIT .AND. 37B IF ( ISWIT .GE. 20B) GO TO 130 * 139 CALL PARAM (LU, WAVE, I, RAOFS, DEOFS, FNOFS, HPOFS, * BMSEP) 130 CONTINUE * 140 CONTINUE * FIND THE SOURCE FILE DATA AND CHECK IT * 300 CONTINUE WRITE (LU,3000) 3000 FORMAT(//3X," Name of source file ?_") READ (LU,3100) FILNAM 3100 FORMAT(3A2) * * Find the number of the starting source 320 WRITE (LU,3130) 3130 FORMAT(/3X," First source number ? :_") READ (LU,*) NFIRST * * Confirm that this is correct * WRITE (LU,3150) (FILNAM(J), J=1,3), NFIRST 3150 FORMAT(/3X," Using source file ",3A2,/ * 3X," and 1950.0 coordinates. ",/ * 3X," Starting at source ",I4,// * 6X," OK? (TRUE or FALSE) :_") READ (LU,1080) AOK IF ( .NOT. AOK ) GO TO 300 * * OPEN SOURCE FILE. If not found negative error IERR is returned. * CALL OPEN (FDCB,IERR,FILNAM) IF (IERR .GT. 0) GO TO 350 WRITE (LU,3200) IERR 3200 FORMAT(" FILE NOT FOUND, FMP ERROR ",I6) GO TO 300 * * File opened successfully. Close again temporarily. 350 CALL CLOSE (FDCB,IERR) NREC = 0 START = .TRUE. * * Derive name of results file, RESFIL. * IF ( ITIME(5) .GE. 100 ) GO TO 380 IF ( ITIME(5) .GE. 10 ) GO TO 370 * CALL CODE WRITE (IDUMY,3300) RESFIL(2), ITIME(5) 3300 FORMAT( A2, I1) GO TO 390 * 370 CALL CODE WRITE (IDUMY,3400) RESFIL(2), ITIME(5) 3400 FORMAT( A1, I2) GO TO 390 * 380 CALL CODE WRITE (IDUMY,3500) ITIME(5) 3500 FORMAT( I3) * 390 CALL CODE WRITE (RESFIL, 3600) RESFIL(1), (IDUMY(J), J=1,2) 3600 FORMAT(2A2,A1) * WRITE (NAMRFL, '(3A2,A2,A2)') (RESFIL(L),L=1,3),'::', ICR * * Open file, if it exists. 810 CALL OPEN (IDCB, IERR, RESFIL, IDCBS) * * Otherwise create file. IF (IERR .EQ. -006) GO TO 820 IF (IERR .GE. 0) GO TO 825 * * Close and write error. 815 CALL CLOSE (IDCB) WRITE (LU,8400) IERR 8400 FORMAT(/" FMGR ERROR ",I4," CHECK STATUS. OK (T)?_") READ (LU,1080) AOK IF ( .NOT. AOK ) GO TO 900 GO TO 810 * * Create file. * If file is for 1144-37 measurements then smaller 820 IF (FILNAM(2) .EQ. 12593) ISIZE = 20 CALL CREAT (IDCB, IERR, RESFIL, ISIZE, ITYPE, ISECU, ICR,IDCBS) IF (IERR .LT. 0) GO TO 815 * 825 CALL CLOSE (IDCB) WRITE (LU,8500) (RESFIL(L), L=1,3) 8500 FORMAT(/2X," Results are in disc file ",3A2) * PRINT'(//3X,"SOURCE",4X,"HA",3X,"WAVE",4X,"START",5X,"BEAM/", * 29X,"FLUX +- ERROR",40X,"NOISE")' PRINT '("No. Name",2X,"(hr)",2X,"(cm)",2X,"TIME (UT)", * 3X,"SCAN","_")' PRINT '(4X,"FN",12X,"HP",12X,"ON",12X,"HP",12X,"FN",12X,"CE", * 4X,"DIODE (DVM)")' * PRINT '(131"=")' * * Read the parameters of 1 source. Close the file after reading. * * START OF LOOP FOR EACH SOURCE. * 500 CONTINUE * * Allow SCHDL to interrupt CALL RNCLW(IRN) * * Check if BIT 15 has been set * IF(ISSW(15) .LT. 0) GO TO 900 NREC = NREC + 1 * * Program suspends here if bit 13 set or BREAK IF ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) ) GO TO 512 * * Read S reg, reset bit 13, clear reg and pause. ISWIT = SWIN(0) ISWIT = ISWIT .AND. 157777B CALL ISSR(0) WRITE (LU,5010) 5010 FORMAT(/" TNSTP SUSPENDED - GO,TNSTP to restart"///) * REG = 0.0 REG = EXEC(7) * * GO,TNSTP,NSKIP NSKIP is the no. of sources to skip on restart * If NSKIP omitted, program restarts at point of suspension * B register >0 if parameter follows GO command. * IF ( IAB(2) ) 510, 510, 505 * 505 CALL RMPAR (IPRAM) NREC = NREC + IPRAM(1) * * On restart..... * 510 CALL ISSR(0) CALL SWOUT(ISWIT) * CALL EXEC (11,ITIME,IYEAR) PRINT '(//"Restarted at ",2I5," Day",2I5)',(ITIME(LT), * LT = 4,3,-1), ITIME(5), IYEAR * * Bit 14 set for skip to next source. 512 IF (ISSW(14) .GE. 0) GO TO 515 * * Reset bit 14 ISWIT = SWIN(0) ISWIT = ISWIT .AND. 137777B CALL SWOUT(ISWIT) GO TO 500 * 515 CALL OPEN (FDCB,IERR,FILNAM) IF(IERR .GE. 0) GO TO 520 WRITE (LU,3200) IERR GO TO 300 * * Position pointer in file -then read line of ASCII data * 520 CALL POSNT(FDCB,IERR,NREC,1) CALL READF(FDCB,IERR,SORSBF,40,LEN) * IF (IERR .GE. 0) GO TO 530 WRITE (LU,5110) IERR, NREC 5110 FORMAT (" FILE ERROR ",I6," AT LINE ",I6," PROGRAM ENDS ") GO TO 900 * 530 IF( START .AND. LEN .LE. 0) GO TO 532 * GO TO 535 532 WRITE (LU,5120) 5120 FORMAT (" SOURCE NUMBER NOT FOUND ") GO TO 320 * 535 IF( LEN .GT. 0) GO TO 540 * ccccccccccccc comment out to save paper MJG 1995 10 19 c WRITE (LU,5130) c5130 FORMAT (" END OF SOURCE FILE. RETURN TO No. 1"//) * NREC = 0 GO TO 500 * * Convert the ASCII data off the source file to BINARY * 540 CALL CODE READ (SORSBF,5200) NSORS, SORSNM, RH, RM, RS, * DD, DM, DS, CALSRS, NO3P4 5200 FORMAT(I3, 5A2, F2.0, F3.0, F5.1, F4.0, 2F3.0, L2, L1) * * Continue with next source if not starting IF ( .NOT. START ) GO TO 560 * * If starting, check if wanted source has been found IF ( NSORS .EQ. NFIRST) GO TO 560 * * Otherwise increment NREC and read next line of file NREC = NREC + 1 GO TO 520 * * Close file after source has been found 560 CALL CLOSE (FDCB,IERR) START = .FALSE. * * Calculate source coordinates RA0,DEC0 (ie. 1950) in decimal degrees * RA0 = (( RH*60.0 + RM ) * 60.0 + RS)/240.0 IF( DD .NE. 0.0 ) GO TO 580 DD = 0.00001 IF (( SORSBF(13) .AND. 77400B) .EQ. 26400B) DD = -DD 580 DM = SIGN(DM,DD) DS = SIGN(DS,DD) DEC0 = DD + DM/60.0 + DS/3600.0 IF ( DEC0 .GT. 270.0) DEC0 = DEC0 - 360.0 * * Precess coords to current time * RAP = RA0 DECP = DEC0 CALL EXEC (9,DPRC2,IANG(1),IANG(2),IANG(3),IANG(4),IANG(5)) CALL RMPAR (IANG) * * Check offset of source from sun * CALL CLOSN (RAP, DECP, RASUN, DECSUN, NSORS, sorsnm, * *500, ksun) * * Obtain and print SIDERIAL TIME. * STNOW = TIME(2) ISTH = STNOW / 3600.0 ISTM = (STNOW - FLOAT(ISTH) * 3600.0) / 60.0 ISTS = STNOW - FLOAT(ISTH) * 3600.0 - FLOAT(ISTM) * 60.0 * c WRITE (LU,5900) ISTH, ISTM, ISTS c5900 FORMAT(//2X," Siderial time: HH MM SS: ",/17X,3I3) * * Check the source HA. Skip or wait as necessary. * RAHRS = RAP / 15. SIDHRS = STNOW / 3600. HA = SIDHRS - RAHRS IF ( HA .GT. 12. ) HA = HA - 24. IF ( HA .LT. -12.) HA = HA + 24. * * Compare with limiting value * HA = HA * 15. ! Subroutine uses degrees CALL LIMIT (HA, DECP, BELOW) HA = HA / 15. * If ( BELOW ) then * WRITE (LU,5950) NSORS, HA 5950 FORMAT(/,"Source",I4," HA",F6.2,"below horizon", * "GO TO NEXT SOURCE") NJUMPS = NJUMPS + 1 If (NJUMPS .GE. 70) then * PRINT '("Too many jumps. Wait 30 min")' CALL EXEC (12, 0, 3, 0, -30) NREC = NREC - NJUMPS IF (NREC .LT. 0) NREC = 0 NJUMPS = 0 endif GO TO 500 else NJUMPS = 0 endif * * Print source file information and headers for each track. * c 600 WRITE (LU,6000) c6000 FORMAT(/1X," NO. SOURCE RA DEC Cal? 3.4? ") c WRITE (LU,6100) c6100 FORMAT(1X,"_") c CALL EXEC (2,LU,SORSBF,LEN) * write (lu,6250) nsors, (sorsnm(l), l=2,5), ha 6250 format (i3,1x,4a2,1x,f3.1,"_") FIRST = .TRUE. * * Print HEADERS for each track * c WRITE (LU,6200) c6200 FORMAT(//8X," FREQ PLACE START TRACK AT",12X,"FLUX"/ c * 8X," USED(cm) TRACKED RA",7X,"DEC",6X,"TIME",8X,"(Jy)" c * /8X,8"=",2X,7"=",1X,7"=",2X,7"=",2X,8"=",4X,7"=") * * Write housekeeping on results file. * HKEEP = .TRUE. CALL WINFO (LU, NFRQ, RESFIL, WVTB, WAVE, * NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, *900,k) HKEEP = .FALSE. IF ( PROB ) GO TO 900 GO TO 698 * * Start point for repeat of source. * Reset bit 10 ie cancel source repeat. 690 ISWIT = SWIN(0) ISWIT = ISWIT .AND. 175777B CALL SWOUT(ISWIT) * * START OF LOOP FOR EACH FREQUENCY. * 698 NSETS = NSETS + 1 * DO 700 I=1,NFRQ * * Skip 3.4 cm meas on designated sources * IF ( NO3P4 .AND. WAVE(I) .EQ. 3.4 ) GO TO 700 * * Bits 0,1,2,3,4 set for skip 3.4,6.2,13.0,18.0,6.1 cm. measurements ISWIT = SWIN(0) ISWIT = ISWIT .AND. 000037B GO TO (702, 701, 703, 704, 705) I * 701 ISWIT = ISWIT .AND. 1B IF ( ISWIT .EQ. 1B ) GO TO 700 GO TO 711 702 ISWIT = ISWIT .AND. 3B IF ( ISWIT .GE. 2B ) GO TO 700 GO TO 711 703 ISWIT = ISWIT .AND. 7B IF ( ISWIT .GE. 4B ) GO TO 700 GO TO 711 704 ISWIT = ISWIT .AND. 17B IF ( ISWIT .GE. 10B) GO TO 700 GO TO 711 705 ISWIT = ISWIT .AND. 37B IF ( ISWIT .GE. 20B) GO TO 700 * 711 DUALBM = ((WAVE(I) .EQ. 3.4) .OR. (WAVE(I) .EQ. 6.2)) * if (FIRST) then FIRST = .FALSE. write (lu,7100) wave(i) 7100 format(2x, f4.1,3x,"_") else write (lu,7150) wave(i) 7150 format(16x, 2x, f4.1,3x,"_") endif * * Calculate antenna coords for each track and then track source. * * * Correct for BEAM OFFSETS ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * GO TO 715 * * Start point for repeat of particular freq. * Reset bit 9 ie. cancel freq repeat. * 710 ISWIT = SWIN(0) ISWIT = ISWIT .AND. 176777B CALL SWOUT (ISWIT) * 715 continue * call exec (11,timeon) write (lu,7200) timeon(4),timeon(3),timeon(2) 7200 format(3(i2,1x),"_") * DO 720 LBM = 1, 2 * IF (.NOT. DUALBM .AND. LBM .GE. 2) GO TO 720 * if (lbm .eq. 1) then write (lu,7250) 7250 format (1x,"A","_") else print '(/,31x,4x,"B","_")' endif * print '("Dec _")' * SEPFAC = -1. * SEPFAC * * TRACKING AT FIRST NULL. * Calculate coordinates: * TRA = ONRA - SEPFAC TDEC= ONDEC + FNOFS(I) KPLACE = 2HFN * IF (LBM .EQ. 1) FIRE = .TRUE. IF (LBM .EQ. 1) WVTB = .TRUE. * * Print source information. * Track the source, print time antenna settles and track * for required length of time- set in DATA statement. * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * TRACKING AT HALF POWER POINTS. * Calculate coodinates * TRA = ONRA - SEPFAC TDEC= ONDEC + HPOFS(I) KPLACE = 2HHP * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * TRACK ON SOURCE ie. at antenna beam peak. * TRA = ONRA - SEPFAC TDEC = ONDEC KPLACE = 2HON * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * TRACK AT HALF POWER * * TRA = ONRA - SEPFAC TDEC= ONDEC - HPOFS(I) KPLACE = 2HHP * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * * TRACK AT FIRST NULL. * TRA = ONRA - SEPFAC TDEC= ONDEC - FNOFS(I) KPLACE = 2HFN * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * Track at HP and FN pts offset in RA * print '(/,37x,"RA _")' * TRA = ONRA - SEPFAC - FNOFS(I)/CORDEC TDEC = ONDEC KPLACE = 2HFN * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * TRA = ONRA - SEPFAC - HPOFS(I)/CORDEC TDEC = ONDEC KPLACE = 2HHP * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * TRACK ON SOURCE ie. at antenna beam peak. * TRA = ONRA - SEPFAC TDEC = ONDEC KPLACE = 2HON * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * TRA = ONRA - SEPFAC + HPOFS(I)/CORDEC TDEC = ONDEC KPLACE = 2HHP * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * TRA = ONRA - SEPFAC + FNOFS(I)/CORDEC TDEC = ONDEC KPLACE = 2HFN CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF ( NEXT ) GO TO 700 IF ( PROB ) GO TO 900 * * For dual beam systems, take meas at centre * If (DUALBM .AND. LBM .EQ. 1) then * TRA = ONRA TDEC = ONDEC KPLACE = 2HCE * CALL DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) IF (NEXT) GO TO 700 IF (PROB) GO TO 900 endif * 720 CONTINUE * * Write fluxes etc from each position to file RESFIL * CALL WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM, * NL, HKEEP, WVTB, RPTFQ, *900,k) * * Write out used value of noise tube in DVM units c PRINT '("Noise tube ",F12.4," DVM units.", c * " Assuming tube equivalent flux ",F8.2," Jy")', c * TUBNET, tuflux(i) * print '(12x,f10.4)', tubnet * * Bit 13 set for repeat of current frequency. * RPTFQ = .FALSE. IF ( ISSW(9) .GE. 0) GO TO 700 RPTFQ = .TRUE. GO TO 710 * 700 CONTINUE * * Bit 14 set for repeat of current source. * IF ( ISSW(10) .LT. 0) GO TO 690 * print '(/)' * * Go back to run for next source. GO TO 500 900 CONTINUE * CALL TRACK (2, 0.0, 334.114, .FALSE., .FALSE.) * IF (KERR .EQ. 0) GO TO 910 * WRITE (LU,9960) 9960 FORMAT(/," Limit for 6 sig fig accuracy exceeded at:"/ * " Source no. Wave. Value. ") DO 905 KKK = 1,KERR * IF ( KKK .LE. 10 ) GO TO 904 WRITE (LU,9965) KERR 9965 FORMAT(" Limit exceeded >10 times ...", I3, * " times, in fact. ") GO TO 906 904 WRITE (LU,9970) ERSORS(KKK), ERWAV(KKK), * ERSQAV(KKK) 9970 FORMAT(6X, I4, 8X, F6.1, 5X, G12.6) 905 CONTINUE * 906 WRITE (LU,9975) 9975 FORMAT(" If Source no. is >1000, error occurred" * " in reading TUBE."/ * " Subtract 1000 to get source no.") * 910 WRITE (LU,9980) NUMTRK 9980 FORMAT(//" Number of tracks performed:", I4) WRITE (LU,9990) NSETS 9990 FORMAT(/" Total number of sets of readings obtained:",I4) * WRITE (LU,9999) 9999 FORMAT(///" *** END *** "///) 1080 FORMAT(L6) END * ********************************************************************* * * SOURCE TRACKING SUBROUTINE. Now uses DRIVE as a son program * TRCK and WAIT added as new parameters. * ********************************************************************* * SUBROUTINE TRACK (INTYPE, INLONG, INLAT, INTRACK, INWAIT) * INTEGER INTYPE REAL INLONG, INLAT LOGICAL INTRACK, INWAIT * INTEGER*2 TYPE, IBUF(7), DRIVE(3) REAL*4 ALONG, ALAT LOGICAL*2 TRCK, WAIT * EQUIVALENCE (IBUF(1),TYPE), (IBUF(2),ALONG), * (IBUF(4),ALAT), (IBUF(6),TRCK), * (IBUF(7),WAIT) * DATA DRIVE /'DRIVE '/ * TYPE = INTYPE ALONG = INLONG ALAT = INLAT TRCK = INTRACK WAIT = INWAIT * * Call DRIVE with the parameters as sepcified in the call * CALL EXEC (9,DRIVE,0,0,0,0,0,IBUF,7) * RETURN END * ********************************************************************* * * SUBROUTINE TO TRACK SOURCE, PRINT SOURCE INFO,SETTLING TIME AND * STAY ON SOURCE FOR REQUIRED TIME. * Uses subroutines TRACK, FLUX, WINFO * ********************************************************************** * SUBROUTINE DOTRK (TRA, TDEC, NUMTRK, WVTB, WAVE, * LU, NFRQ, TUFLUX, RESFIL, NAMRFL, * SFLUX, SERR, DVM, CPLACE, NL) * CHARACTER CPLACE(21)*2, NAMRFL*10 * LOGICAL NEXT, PROB, HKEEP, FIRE, RPTFQ, WVTB, CALSRS * INTEGER TIMON(5), RESFIL(3), ITIME(5), SORSNM(5), * IDCB(272), ERSORS(10) * REAL WAVE(1), TUFLUX(1), ERWAV(10), ERSQAV(10), MEDTB, MEDVM, * SFLUX(21), SERR(21), DVM(21) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * NUMTRK = NUMTRK + 1 * c WRITE (LU,1000) WAVE(I), KPLACE, TRA, TDEC c1000 FORMAT(9X, F5.1, 6X, 1A2, 4X, F7.3, 2X, F7.3,"_") * CALL TRACK (4, TRA, TDEC, .TRUE., .TRUE.) * c CALL EXEC (11,TIMON) c WRITE (LU,1100) TIMON(4), TIMON(3), TIMON(2) c1100 FORMAT(I4, 2I3," _") * * Turn on DVM's, fire noise tube and compute source FLUX and * RMS ERROR. * CALL FLUX (LU, TUFLUX, WAVE) IF ( NEXT ) GO TO 911 * * Write source info onto disc file RESFIL. * CALL WINFO (LU, NFRQ, RESFIL, WVTB, WAVE, * NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, *911,k) * 911 RETURN END * ********************************************************************* * * SUBROUTINE TO WRITE DATA TO RESULTS FILE * ********************************************************************* * SUBROUTINE WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM, * NL, HKEEP, WVTB, RPTFQ, k,*) * CHARACTER NAMRFL*10, SEGNAM*5, CPLACE(21)*2, FCHAR*42 * LOGICAL HKEEP, WVTB, RPTFQ * REAL SFLUX(21), SERR(21), DVM(21) * * File operations * * Open file,if it exists * Assign 110 to label NSTMT=110 SEGNAM = 'WRTFL' 110 OPEN (50, file=NAMRFL, iostat=ierr, err=820, status='OLD') * * Find EOF Assign 120 to label NSTMT=120 120 DO WHILE (ierr .ne. -1) READ (50, '(A42)', iostat=ierr, err=820, end=150) * FCHAR end do Assign 150 to label NSTMT=150 150 BACKSPACE(50, iostat=ierr, err=820) * * Write info to file * Assign 160 to label NSTMT=160 DO 165 ILN = 1,NL * 160 WRITE (50, 1100, iostat=ierr, err=820) * HKEEP, WVTB, CPLACE(ILN), SFLUX(ILN), SERR(ILN), * RPTFQ, DVM(ILN) 165 CONTINUE * 1100 FORMAT (L1, L1, A2, G12.6, G12.6, L2, G12.6) * * Write EOF Assign 170 to label NSTMT=170 170 ENDFILE (50, iostat=ierr, err=820) * Assign 180 to label NSTMT=180 180 CLOSE (50, iostat=ierr, err=820) * GO TO 900 * * General error checking. * 820 Call ERMSG (ierr, NSTMT, ' ', *900, k) GO TO label * 900 RETURN k END * ********************************************************************* * BLOCK DATA * ********************************************************************* * LOGICAL HKEEP, PROB, NEXT, FIRE, RPTFQ, CALSRS * INTEGER SORSNM, ERSORS * REAL MEDTB, MEDVM * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM(5), KPLACE, * IDCB(272), NSORS, I, ITIME(5), * IYEAR, RPTFQ, ERSORS(10), ERWAV(10), KERR, * ERSQAV(10), CALSRS, IDCBS, TUBNET * END * ********************************************************************* * * FUNCTION TO OBTAIN UNIVERSAL- OR SIDERIAL TIME. * Returns UT if L = 1, ST if L = 2 (in SECONDS) * Time in decimal year for L = 3 (less 1900.) * ********************************************************************* * FUNCTION TIME(L) * INTEGER IT(5) EQUIVALENCE (IT(1),MS), (IT(2),IS), (IT(3),M), * (IT(4),IH), (IT(5),ID) DATA BASEOF / 84 806.882 /, LSTDAY / 0 /, * RATE / 0.002 737 909 3 / * * Calculate UT CALL EXEC (11, IT, IYR) TIME = FLOAT(IH*60 + M) * 60.0 + FLOAT(IS) + FLOAT(MS)/100. IF (L .LT. 2) GO TO 900 IF (L .EQ. 3) GO TO 300 * * Calculate ST. IF (ID .NE. LSTDAY) * OFFSET = FLOAT((IYR-1979)*365 + (IYR-1977)/4 + ID - 258) * * 236.55536 + BASEOF + 6644.4 TIME = TIME + TIME * RATE + OFFSET TIME = TIME - FLOAT(IFIX(TIME/86400.0)) * 86400.0 GO TO 900 * * Calculate time in decimal YEAR * 300 TIME = ((TIME/86400.) + FLOAT(ID))/365. + FLOAT(IYR) TIME = TIME - 1900. 900 RETURN END * ********************************************************************* * * SUBROUTINE TO ARRANGE FLUXES IN ASCENDING ORDER AND * CALCULATE THE MEDIAN. * Uses REAL variables. * ********************************************************************* * SUBROUTINE MEDIN (LU, RDVM, ICOUNT, MEDVM, DIGVM) * REAL DIGVM(1), MEDVM * DO 110 J = 1,ICOUNT * * Rise thru' array until position of value is found. IF ( RDVM .LE. DIGVM(J) ) GO TO 130 * 110 CONTINUE * DIGVM(ICOUNT) = RDVM GO TO 900 * * Shift all subsequent values up the array. 130 DO 140 K = ICOUNT,J,-1 DIGVM(K+1) = DIGVM(K) 140 CONTINUE * DIGVM(J) = RDVM * 900 CONTINUE * MIDL = ICOUNT/2 MEDVM = DIGVM(MIDL) * * RETURN END * ********************************************************************* * * SUBROUTINE TO CHANGE VALUES OF BEAM PARAMETERS. * ********************************************************************* * SUBROUTINE PARAM (LU, WAVE, I, RAOFS, DEOFS, FNOFS, HPOFS, * BMSEP) * LOGICAL AOK * REAL WAVE(1), RAOFS(1), DEOFS(1), FNOFS(1), HPOFS(1), * BMSEP(1) * 201 CONTINUE WRITE (LU,2010) WAVE(I), RAOFS(I), DEOFS(I) 2010 FORMAT(//3X," HA and DEC beam offsets for ",F5.1,"cm."/ * 3X," system are: ",2F7.3," degrees "/ * /5X," OK (TRUE) or new values wanted (FALSE) ? _") READ (LU,1080) AOK IF ( AOK ) GO TO 202 * WRITE (LU,2020) WAVE(I) 2020 FORMAT(//3X," Enter new values for HA and DEC BEAM OFFSET "/ * 3X," for the ",F5.1," cm. system: _") READ (LU,*) RAOFS(I), DEOFS(I) GO TO 201 * * Check the values for the FIRST NULL points * 202 CONTINUE * WRITE (LU,2030) WAVE(I), FNOFS(I) 2030 FORMAT(/3X," FIRST NULL offset for ",F5.1," cm." * /3X," system is: ",F7.3," degrees. ",/ * 6X," OK (TRUE) or new value wanted (FALSE) ?_") * READ (LU,1080) AOK IF ( AOK ) GO TO 203 WRITE (LU,2040) WAVE(I) 2040 FORMAT(/3X," Enter new value for FIRST NULL" * " offset"/ * 3X," for the ",F5.1," cm. system:_") * READ (LU,*) FNOFS(I) * GO TO 202 * * Check the values for the HALF POWER points are correct * 203 CONTINUE WRITE (LU,2050) WAVE(I), HPOFS(I) 2050 FORMAT(/3X," HALF POWER offset for ",F5.1," cm",/ * 3X," system is:",F7.3," degrees ",/ * 6X," OK (TRUE) or new value wanted (FALSE) ?_") * READ (LU,1080) AOK IF (AOK) GO TO 231 * WRITE (LU,2060) WAVE(I) 2060 FORMAT(/3X," Enter new value for HALF" * " POWER offset ",/ * 3X," for the ",F5.1," cm. system:_") * READ (LU,*) HPOFS(I) GO TO 203 * * Check the BEAM SEPARATION * 231 WRITE (LU,2070) WAVE(I), BMSEP(I) 2070 FORMAT(/3X," BEAM SEPARATION of the ",F5.1," cm. "/ * 3X," system is: ",F7.3," degrees. "/ * 6X," OK (TRUE) or new values wanted (FALSE) ?_") * READ (LU,1080) AOK IF ( AOK ) GO TO 900 WRITE (LU,2075) WAVE(I) 2075 FORMAT(/3X," Enter new values for BEAM SEPARATION "/ * 3X," for the ",F5.1," cm. system : _") * READ (LU,*) BMSEP(I) GO TO 231 * 1080 FORMAT(L6) * 900 RETURN END * *********************************************************************** * * Subroutine to read values of sun rise,set-times and coords * from disc file * *********************************************************************** * SUBROUTINE SUNTM (NOWDAY, UHSET, UMSET, UHRISE, UMRISE, * RASUN, DECSUN, k,*) * CHARACTER NAMFIL*10 * INTEGER SHRISE, SMRISE, SHSET, SMSET, UHSET, UMSET, UHRISE, * UMRISE, RHSUN, RMSUN, DAY, YEAR, DATE * DATA NAMFIL /'SUNTIM::16'/ * * Open, read and close file * Assign 110 to label NSTMT = 110 110 OPEN (10, file=NAMFIL, iostat=ierr, err=820, status='OLD') * * Find today's times and coords * DO WHILE (NOWDAY .NE. DAY) Assign 120 to label NSTMT = 120 120 READ (10, 1200, iostat=ierr, err=820) DAY, YEAR, MONTH, * DATE, SHSET, SMSET, SHRISE, SMRISE, UHSET, * UMSET, UHRISE, UMRISE, RHSUN, RMSUN, DECSUN * END DO Assign 160 to label NSTMT = 160 160 CLOSE (10, iostat=ierr, err=820) * RASUN = (FLOAT(RHSUN) + FLOAT(RMSUN)/60.) * 15. !Decml deg * GO TO 900 * * Error handling * 820 Call ERMSG (ierr, NSTMT, ' ', *900, k) GO TO label * 1200 FORMAT (I3, I4, 12I2, F7.3) * 900 RETURN k END * * ************************************************************************ * * Subroutine to calculate source angular separation from sun * and to skip source if too close * *********************************************************************** * SUBROUTINE CLOSN (RAP, DECP, RASUN, DECSUN, NSORS, sorsnm, * ksun,*) * integer sorsnm(5) * DATA SUNLIM / 20. / * ksun = 0 RADIF = RAP - RASUN DECDIF = DECP - DECSUN * IF (RADIF .GT. 180.) RADIF = RADIF - 360. IF (RADIF .LT. -180.) RADIF = RADIF + 360. IF (DECDIF .GT. 180.) DECDIF = DECDIF - 360. IF (DECDIF .LT. -180.) DECDIF = DECDIF + 360. * C PRINT '("RAP, RASUN, DECP, DECSUN, RADIF, DECDIF",6(2X,F6.3))', C * RAP, RASUN, DECP, DECSUN, RADIF, DECDIF * If ((ABS(RADIF) .LT. SUNLIM) .AND. * (ABS(DECDIF) .LT. SUNLIM)) then PRINT '(/"Source ",I4,2x,5a2," too close to sun"/ * "RA and DEC angular separation from sun resp.", * 2(2X,F6.2),/ * "Source skipped")', NSORS, (sorsnm(l),l=1,5), * RADIF, DECDIF * ksun = 1 endif * RETURN ksun END * ********************************************************************* * * Subroutine for suspending observing program. * * NREC is the parameter that can be modified with the GO * command; eg. to skip sources GO,PROGNM,NSKIP where NSKIP * is added to NREC on restart. * ********************************************************************* * SUBROUTINE SSPND (NREC, PRGNAM, PSUSPD) * CHARACTER PRGNAM*5 * LOGICAL PSUSPD, IFBRK * INTEGER SWIN, IAB(2), IPRAM(5), ITIME(5) * EQUIVALENCE (REG,IAB(1)) * DATA SSLIMT / 5. / * PSUSPD = .FALSE. * * Program suspends if S register bit 13 set ON or break flag has * been set by typing *BR,PRGNAM, else continue * If ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) ) GO TO 900 * * Read S-register to preserve reading, reset bit 13 ISWIT = SWIN(0) ISWIT = ISWIT .AND. 157777B CALL ISSR(0) * CALL EXEC (11, ITIME,IYEAR) UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. * PRINT '(/, A5," SUSPENDED. GO,",A5,",NSKIP to restart"/, * 4X,"NSKIP (+ or -) is optional.", * " Use to skip sources on restart")', * PRGNAM, PRGNAM * REG = 0.0 REG = EXEC(7) * * GO,PRGNAM,NSKIP NSKIP is the no. sources to skip on restart * If NSKIP is omitted, program restarts at point of suspension * B register >0 if parameter follows GO command * * If (IAB(2)) 510, 510, 505 * 505 CALL RMPAR(IPRAM) NREC = NREC + IPRAM(1) * * On restart..... * 510 CALL ISSR(0) * Check length of time the program was suspended CALL EXEC (11, ITIME, IYEAR) UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. SUSTIM = UTAFT - UTBEF If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440. If (SUSTIM .GT. SSLIMT) then PRINT '(A1)', CHAR(14B) !Form feed PRINT '("Restarted at",2I5,"Day ",2I5)', (ITIME(L), * L=4,3,-1), ITIME(5), IYEAR PSUSPD = .TRUE. endif * * Replace S-reg value from before suspension CALL SWOUT (ISWIT) * 900 RETURN END * * ********************************************************************* * * SUBROUTINE TO WRITE SOURCE INFO ONTO DISC FILE. * File name RESFIL generated in main program. * ********************************************************************* * SUBROUTINE WINFO (LU, NFRQ, RESFIL, WVTB, WAVE, * NAMRFL, SFLUX, SERR, DVM, CPLACE, NL, k,*) * CHARACTER CPLACE(21)*2, NAMRFL*10 * LOGICAL HKEEP, PROB, RPTFQ, NEXT, FIRE, WVTB, CALSRS * INTEGER RESLT(21), RESFIL(3), IDCB(272), ITIME(5), SORSNM(5), * ERSORS(10) * REAL WAVE(1), ERWAV(10), ERSQAV(10), MEDTB, MEDVM, * SFLUX(21), SERR(21), DVM(21) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * DATA IBLANK / 2H / * If (HKEEP .OR. WVTB) then * * Open file * Assign 110 to label NSTMT=110 110 OPEN (50, file=NAMRFL, iostat=ierr, err=820, status='OLD') * * Find EOF Assign 120 to label NSTMT=120 120 Do while (ierr .ne. -1) READ (50, '(A42)', iostat=ierr, err=820, end=150) * FCHAR end do * Assign 150 to label NSTMT=150 150 BACKSPACE(50, iostat=ierr, err=820) * Assign 160 to label NSTMT=160 160 If (HKEEP) then * * Get decimal time in years. * DECTM = TIME(3) SIDTIM = TIME(2)/3600. !Siderial time in decimal hrs * * Write housekeeping * WRITE (50, 1100, iostat=ierr, err=820) * HKEEP, NSORS, (SORSNM(L), L=1,5), * DECTM, NFRQ, CALSRS, * SIDTIM 1100 FORMAT(L1, I3, 5A2, F8.4, I2, L2, F12.6) * else if (WVTB) then * * Write wavelength and ave. tube DVM value. * WRITE (50, 1200, iostat=ierr, err=820) * HKEEP, WVTB, WAVE(I), MEDTB, * TBDEV, (IBLANK, J=1,5) 1200 FORMAT(L1, L1, F6.1, 2G12.6, 5A2) * NL = 0 WVTB = .FALSE. * endif * * Write EOF Assign 180 to label NSTMT=180 180 ENDFILE (50, iostat=ierr, err=820) * Assign 190 to label NSTMT=190 190 CLOSE (50, iostat=ierr, err=820) * endif * If (.NOT. HKEEP) then * * Assign track info to array for writing to file at end of freq. * NL = NL + 1 WRITE (CPLACE(NL), '(A2)') KPLACE SFLUX(NL) = SORSJY SERR(NL) = ERROR DVM(NL) = MEDVM * endif * GO TO 900 * * General error checking. * 820 Call ERMSG (ierr, NSTMT, ' ', *900, k) GO TO label * 900 CONTINUE * RETURN k END * ********************************************************************* * * SUBROUTINE TO CONTROL DVM's AND NOISE TUBE, AND CALCULATE * AVERAGE FLUX READINGS OF SOURCE. * Calls subroutine MEDIN. * * Uses Fluke DVM 8840 * ******************************************************************** * $ALIAS/DOUT1/,NOALLOCATE SUBROUTINE FLUX (LU, TUFLUX, WAVE) * LOGICAL NEXT, FTUBE, FIRE, HKEEP, PROB, RPTFQ, CALSRS * INTEGER IBUF(4), HASL, SORSNM(5), IDCB(272), * ITIME(5), ERSORS(10) * REAL TUFLUX(1), JYDVM, WAVE(1), DIGVM(651), MEDTB, * MEDVAL, ERWAV(10), ERSQAV(10), PREVTB(3), TBNOM(3), * PREVER(3), MEDIAN * REAL*8 AVDVM, SQAV, AVDSQ, DIFF, DSTDEV, totdvm, sumsq, sqdvm * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVAL, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * COMMON /DOUT1/ ISERVO * DATA NSMPL / 650 /, NTSAM / 650 /, !Remember change DIGVM * TBNOM / -.0564, -.0123, .0202 / * FTUBE = .FALSE. NEXT = .FALSE. IFAIL = 0 NTFAIL = 0 * IF ( I .EQ. 1) IFQ = 2 IF ( I .EQ. 2) IFQ = 1 IF ( I .EQ. 3) IFQ = 3 IF ( I .EQ. 4) IFQ = 4 IF ( I .EQ. 5) IFQ = 2 * * Select DVM inputs, DIRECT, same freq on both. * 100 ISEL = (IFQ * 2 - 1) * 11B CALL EXEC (2, 113B, ISEL, 1, 5, 5) CALL EXEC (12, 0, 2, 0, -1) ! Wait 1 second for settling * * Set up DVM. Default values, medium sampling rate * WRITE (35,'("*S1")') * NSAM = NSMPL IF ( KPLACE .EQ. 2HFN ) NSAM = NSMPL/2 * * Reset ordered array of DVM readings, DVM totals, etc. 110 DO 120 JJ = 1,NSMPL+1 DIGVM(JJ) = 0.0 120 CONTINUE TOTDVM = 0.0 SUMSQ = 0.0 * * Loop to read DVM and average NSAM samples. * DO 200 NN = 1,NSAM * READ (35,*) RDVM * * Keep running total of readings, arranging in order to calc median * CALL MEDIN (LU, RDVM, NN, MEDIAN, DIGVM) * TOTDVM = TOTDVM + RDVM SQDVM = RDVM*RDVM SUMSQ = SUMSQ + SQDVM * 200 CONTINUE * * Turn noise tube off If (FTUBE) then CALL EXEC (2, 113B, 0, 1, 3, 3) endif * * Calculate average and standard deviation. * COUNT = NSAM COUNT2 = NSAM/2 AVDVM = DBLE(TOTDVM / COUNT) SQAV = DBLE(SUMSQ/COUNT) AVDSQ = AVDVM * AVDVM * DIFF = SQAV - AVDSQ If (DIFF .LT. 0.) DIFF = 0. DSTDEV = SQRT( DIFF ) STDEV = SNGL(DSTDEV)/SQRT(COUNT2) * * New Fluke 8840 DVM connections opposite to old DVM * Change for consistency with analysis program C MEDIAN = -1. * MEDIAN * If (FTUBE) then TBDEV = STDEV MEDTB = MEDIAN else VALDEV = STDEV MEDVAL = MEDIAN endif * * Check max value calculated, for 6 sig fig accuracy If ( SQAV .GT. 8.388E07 ) then KERR = KERR+1 If ( KERR .LE. 10 ) then ERSORS(KERR) = NSORS If (FTUBE) ERSORS(KERR) = ERSORS(KERR)+1000 ERWAV(KERR) = WAVE(I) ERSQAV(KERR) = SNGL(SQAV) endif endif * * Check for DVM zero. If (STDEV .EQ. 0.0) then PRINT '("DVM ZERO. Trying again.")' IFAIL = IFAIL + 1 * If (IFAIL .GT. 3) then PRINT '("Too many problems. Try next freq")' NEXT = .TRUE. GO TO 988 else If (FIRE) FTUBE = .FALSE. GO TO 100 endif endif * * If (FIRE) then * * Return to fire tube as necessary If ( .NOT. FTUBE ) then * FTUBE = .TRUE. NSAM = NTSAM * Fire tube and wait 3 sec for trace to settle IFREQ = IFQ+1 if ( i .eq. 5) ifreq = 2 ! 6.1cm tube IF ( IFQ .EQ. 1 ) IFREQ = 1 ! 3.4cm tube CALL EXEC (2, 113B, IFREQ, 1, 3, 3) CALL EXEC (12, 0, 2, 0, -3) GO TO 110 else FTUBE = .FALSE. * * Check that noise tube fired. Nominal minimum set as 2*RMSnoise * change to 4 times 1987 dec 21 mjg TUBNET = MEDTB - MEDVAL !Net tube in DVM units * TLEVL = 4. * STDEV * SQRT(COUNT2) * If ( ABS(TUBNET) .LT. TLEVL ) then PRINT '(/"Noise diode fired ? Trying again.",/ * "STDEV, TBDEV, VALDEV",3(2X,G12.4),/ * "COUNT, TLEVL", 2(2X,G12.4),/ * "MEDIAN, MEDTB, MEDVAL, TUBNET ", * 4(2X,G12.4))', * STDEV, TBDEV, VALDEV, COUNT, TLEVL, * MEDIAN, MEDTB, MEDVAL, TUBNET * NTFAIL = NTFAIL + 1 * * If no. errors is >3, use nominal/previous tube * value, and continue. If (NTFAIL .GT. 3) then TUBNET = PREVTB(IFQ) TBDEV = PREVER(IFQ) If (TUBNET .EQ. 0.0) then TUBNET = TBNOM(IFQ) TBDEV = .07 * TUBNET/TUFLUX(I) endif PRINT '("Using nominal/previous ", * "value of ",G12.4,"+-",G12.4, * " DVM units")', TUBNET, TBDEV else GO TO 100 endif endif PREVTB(IFQ) = TUBNET PREVER(IFQ) = TBDEV * * Correction factor of Jy/DVM unit JYDVM = TUFLUX(I)/ABS(TUBNET) endif endif * * Convert measured values to Jy ERDVM = SQRT( TBDEV*TBDEV + VALDEV*VALDEV) SORSJY = MEDVAL * JYDVM ERROR = ERDVM * JYDVM c PRINT '(F6.3,"+-",F5.3)', SORSJY, ERROR * print '(f6.2,1x,f5.3,1x,"_")', sorsjy, error * 988 FIRE = .FALSE. RETURN END * ********************************************************************** * * SUBROUTINE TO CHOOSE OPERATING FREQS AND SET S REG BITS * ********************************************************************** * SUBROUTINE BITST * PARAMETER (NWAVL=5) * CHARACTER CHAR*1 * LOGICAL AOK, DOFRQ(NWAVL) * INTEGER TIMSET(3), SWIN, ISETBT(NWAVL) * REAL WAVE(NWAVL), WAVUSE(NWAVL) * DATA WAVE / 6.2, 3.4, 13.0, 18.0, 6.1 /, * ISETBT/ 2B, 1B, 4B, 10B, 20B / * 140 PRINT '(/3X,"Wavelengths available :",/ * 6X,5F7.1,"cm",/ * 4X,"Enter which are to be used (in cm.) :_")', * WAVE * READ *, (WAVUSE(L), L=1,NWAVL) * DO 141 L=1,NWAVL+1 DO 138 LN = 1,NWAVL If (WAVUSE(L) .EQ. WAVE(LN)) GO TO 139 138 CONTINUE If (WAVUSE(L) .NE. 0.0) then PRINT '(/3X,"No match for wavelength",F5.1, * 4X,"Check available list")', WAVUSE(L) DO 137 LN = 1,NWAVL WAVUSE(LN) = 0. 137 CONTINUE GO TO 140 endif 139 KOUNT = L-1 IF ( WAVUSE(L) .EQ. 0.0 ) GO TO 142 141 CONTINUE * 142 PRINT '(/3X,"Observing at",I3," wavelengths")',KOUNT * If (KOUNT .LE. 0) then PRINT '("INPUT ERROR")' GO TO 140 endif * 143 PRINT '(6X,"Wavelengths used :")' * DO 144 L = 1,KOUNT PRINT '(20X,F7.1)', WAVUSE(L) 144 CONTINUE * PRINT '(5X,"OK (T or F) ? _")' * READ *, AOK * If ( .NOT. AOK ) then DO 145 L = 1,KOUNT WAVUSE(L) = 0.0 145 CONTINUE GO TO 140 endif * * Set S reg bits according to freqs to be used. * 146 ISWIT = SWIN(0) * DO 200 LB = 1,NWAVL DO 210 LBB = 1,NWAVL DOFRQ(LB) = (WAVUSE(LBB) .EQ. WAVE(LB)) If (DOFRQ(LB)) GO TO 200 210 CONTINUE 200 CONTINUE * DO 250 LB = 1,NWAVL If (.NOT. DOFRQ(LB)) ISWIT = ISWIT .OR. ISETBT(LB) 250 CONTINUE * * Set reg * 150 CALL SWOUT (ISWIT) * RETURN END * *********************************************************************** * * Subroutine to calculate antenna limits * *********************************************************************** * SUBROUTINE LIMIT (HA,DEC,BELOW) * * Find if command angles are below the horizon * Copy of subroutine CMDLM in &STEER * HA input current command hour angle * DEC input current command declination * LOGICAL BELOW * * DEC must be in range -90, +90 If (DEC .GT. 90) then do 110 while (DEC .GT. 90.) DEC = DEC - 180. 110 end do endif If (DEC .LT. -90.) then do 115 while (DEC .LT. -90.) DEC = DEC + 180. 115 end do endif * * Limit command HA for real DEC * ----------------------------- halim = HA realdec = DEC if (realdec .gt. 180.0) realdec = realdec - 360.0 if (halim .lt. 0.0) then * limit command HA in the east alimit = -88.0 if (realdec .gt. -15.0) alimit = 0.45*realdec - 81.25 if (realdec .gt. +25.0) alimit = realdec - 95.0 if (halim .lt. alimit) halim = alimit else * limit command HA in the west alimit = 88.0 if (realdec .gt. -5.0) alimit = -0.3*realdec + 86.5 if (realdec .gt. +5.0) alimit = -realdec + 90.0 if (halim .gt. alimit) halim = alimit endif * * Limit command DEC for real HA * ----------------------------- * declim = DEC * limit command dec in the north alimit = 45.0 realha = HA if (realha .gt. 180.0) realha = realha - 360.0 if (realha .lt. 0.0) then * limit command dec in the east and north if (realha .lt. -50.0) alimit = realha + 95.0 if (realha .lt. -70.0) alimit = 2.222*realha + 180.556 else * limit command dec in the west and north if (realha .gt. 45.0) alimit = -realha + 90.0 if (realha .gt. 85.0) alimit = -3.333*realha + 288.333 endif if (declim .gt. alimit) declim = alimit * limit command dec in the south if (declim .lt. -83.0) declim = -83.0 * BELOW = ((HA .NE. HALIM) .OR. (DEC .NE. DECLIM)) * return end * * * ********* VERSION <990510.1213> * ********************************************************************* * * Subroutine to display errors * ********************************************************************* * SUBROUTINE ERMSG (ierr, NSTMT, SEGNAM, k,*) * CHARACTER SEGNAM*5 * LOGICAL AOK * PRINT '("Error ",(I4)," at statement",(I4)," in ",(A5))', ierr, * NSTMT, SEGNAM k=1 RETURN k END * ********************************************************************* * * Subroutine to allocate and set RN, write observing info to * disc file * ********************************************************************* $ALIAS RNRQ, NOABORT * SUBROUTINE RNALC (IRN) * PARAMETER (MAXPRG = 10) * CHARACTER DATNAM*10, PRGNAM*6, DUMCHR*1, OBPCHR*108, * SHPCHR(MAXPRG)*108, OBPNM*6, SEGNAM*5 * LOGICAL OB3P4, OB6CM, OB13CM, OB18CM, ob2p5, ob4p5, * DUAL34, DUAL6, NADD13, NADD18, NOALC, nadd25, nadd45 * DATA NOBORT / 40000B /, DATNAM /'SHDATA::16'/, * PRGNAM /'TNSTP'/, * OB3P4 /.TRUE./, OB6CM /.TRUE./, OB13CM /.TRUE./, * OB18CM /.FALSE./, * ob2p5 / .false. /, ob4p5 / .false. /, * DUAL34/.TRUE./, DUAL6 /.TRUE./, NADD13 /.TRUE./, * NADD18 /.FALSE./, * nadd25 / .false. / , nadd45 / .false. / * SEGNAM = 'RNALC' * * Open, read and close file containing SCHEDULING parameters * Assign 110 to label NSTMT = 110 110 OPEN (10, file=DATNAM, iostat=ierr, err=820, status='OLD') * * Read file to preserve existing parms from other progs Assign 115 to label NSTMT = 115 115 READ (10,'(A108)', iostat=ierr, err=820) OBPCHR * NPROGS is the no of programs in schedule READ (OBPCHR(1:14),'(I2,A6,I6)', iostat=ierr, err=820) * NPROGS, OBPNM, LLRN READ (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), * K = 1,NPROGS) REWIND 10 ! Get to BOF for writing * If (OBPNM .EQ. PRGNAM) then NOALC = .FALSE. GO TO 118 endif * PRINT '(3X,"Is this program running while ",A6," suspended ?"/ * 9X,"Yes (T) _")', OBPNM READ *, NOALC * * If this prog runs during suspension of a prog that has already * allocated a RN, use this no.- don't allocate another * 118 If ( NOALC ) then ICON = 1B + NOBORT ! Local set CALL RNRQ (ICON, LLRN, ISTAT, *850) IRN = LLRN PRINT '("Local set RN ",I4)', IRN else * * Global allocate and local set RN * ICON = 21B + NOBORT CALL RNRQ (ICON, IRN, ISTAT, *850) C PRINT '("TNSTP global allocate, local set RN ",I4)', IRN * * Write allocated RN to file ALCRNS as record CALL RNFIL (IRN, *900, k) endif * * Write info on this program to disc file, replacing other info * Assign 120 to label NSTMT = 120 120 WRITE (10, 1200, iostat=ierr, err=820) NPROGS, PRGNAM, * IRN, OB3P4, OB6CM, OB13CM, OB18CM, * ob2p5, ob4p5, * DUAL34, DUAL6, NADD13, NADD18, * nadd25, nadd45 WRITE (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), * K = 1,NPROGS) * Assign 160 to label NSTMT = 160 160 CLOSE (10, iostat=ierr, err=820) * GO TO 900 * * Error handling * * 820 If (ierr .eq. 462) then PRINT '("Disc file ",(A10)," does not exist."/, * "Run SHPRM on other terminal to create it."/ * "Hit RETURN when done.", * " _")', DATNAM READ '(A1)', DUMCHR GO TO 110 else * Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) GO TO label endif * * RN errors 850 PRINT '("Error in RNALC for ICON, IRN, ISTAT = ",K6,2I5)', * ICON, IRN, ISTAT * 900 RETURN * 1200 FORMAT (I2, A6, I6, 12L2, 70X) END * ********************************************************************* * * SUBROUTINE TO WRITE ALLOCATED RN's TO FILE * ********************************************************************* * SUBROUTINE RNFIL (IRN, k,*) * CHARACTER NAMFIN*10, SEGNAM*5 * DATA NAMFIN / 'ALCRNS::16' / * SEGNAM = 'RNFIL' * * File operations * * Open file,if it exists * Assign 110 to label NSTMT=110 110 OPEN (20, file=NAMFIN, iostat=ierr, err=810, status='OLD') * * Find EOF Assign 120 to label NSTMT=120 120 DO WHILE (ierr .ne. -1) READ (20, 1100, iostat=ierr, err=820, end=150) IRNFIL end do Assign 150 to label NSTMT=150 150 BACKSPACE(20, iostat=ierr, err=820) * * Write info to file * Assign 160 to label NSTMT=160 160 WRITE (20, 1100, iostat=ierr, err=820) IRN * * Write EOF Assign 170 to label NSTMT=170 170 ENDFILE (20, iostat=ierr, err=820) * Assign 180 to label NSTMT=180 180 CLOSE (20, iostat=ierr, err=820) * GO TO 900 * * Error handling * * Check if error due to file not existing. * 810 If (ierr .eq. 462) then PRINT '("Creating file ",(A10)," for list of allocated RN")', * NAMFIN OPEN (20, file=NAMFIN, iostat=ierr, err=820, status='NEW') * GO TO 120 endif * * General error checking. * 820 Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) GO TO label * 1100 FORMAT (I6) * 900 RETURN k END * ********************************************************************* * * Subroutine for end of observing program cycle. * Clears, waits, sets RN to allow break-in of daily prog. * ********************************************************************* * $ALIAS RNRQ, NOABORT * SUBROUTINE RNCLW (IRN, PSUSPD) * LOGICAL PSUSPD * INTEGER SWIN, ITIME(5) * DATA NOBORT / 40000B /, * SSLIMT / 1. / !Limit IN MINUTES after which * program assumes interruption was significant PSUSPD = .FALSE. * * Read S-register to preserve reading ISWIT = SWIN(0) * * Clear RN CALL EXEC (11, ITIME, IYEAR) UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. * ICON = 4B + NOBORT CALL RNRQ (ICON, IRN, ISTAT, *850) C PRINT '("TNSTP clears RN ",I4)', IRN * * Wait 3 sec so scheduling prog can cut in if waiting CALL EXEC (12, 0, 2, 0, -3) * * Request local set ICON = 1B + NOBORT CALL RNRQ (ICON, IRN, ISTAT, *850) C PRINT '("TNSTP locally sets RN ",I4)', IRN * * Check length of time the program was suspended CALL EXEC (11, ITIME, IYEAR) UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. SUSTIM = UTAFT - UTBEF If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440. If (SUSTIM .GT. SSLIMT) then PRINT '(A1)', CHAR(14B) !Form feed PRINT '("Restarted at",2I5," Day",2I5)', (ITIME(L), * L=4,3,-1), ITIME(5), IYEAR PSUSPD = .TRUE. endif * * Replace S-reg value from before suspension CALL SWOUT (ISWIT) * GO TO 900 * * Error point 850 PRINT '("Error in RNCLW for ICON, IRN, ISTAT = ", K6, 2I5)', * ICON, IRN, ISTAT * 900 RETURN END * ********************************************************************* * * Subroutine for suspending observing program. * Clears RN, suspends obs prog till GO command, sets RN. * * NREC is the parameter that can be modified with the GO * command; eg. to skip sources GO,PROGNM,NSKIP where NSKIP * is added to NREC on restart. * ********************************************************************* * $ALIAS RNRQ, NOABORT * SUBROUTINE SUSPD (IRN, NREC, PSUSPD) * LOGICAL PSUSPD, IFBRK * INTEGER SWIN, IAB(2), IPRAM(5), ITIME(5) * EQUIVALENCE (REG,IAB(1)) * DATA NOBORT / 40000B /, SSLIMT / 5. / * PSUSPD = .FALSE. * * Program suspends if S register bit 13 set ON or break flag has * been set by typing *BR,PRGNAM, else continue * If ( ISSW(13) .GE. 0 .AND. .NOT. IFBRK(0) ) GO TO 900 * * Read S-register to preserve reading, reset bit 13 ISWIT = SWIN(0) ISWIT = ISWIT .AND. 157777B CALL ISSR(0) * * Clear RN CALL EXEC (11, ITIME,IYEAR) UTBEF = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. ICON = 4B + NOBORT CALL RNRQ (ICON, IRN, ISTAT, *850) C PRINT '("TNSTP clears RN ",I4)', IRN * PRINT '(/"TNSTP SUSPENDED. GO,TNSTP,NSKIP to restart"/, * 4X,"NSKIP (+ or -) is optional. Use to skip sources on restart")' * REG = 0.0 REG = EXEC(7) * * GO,TNSTP,NSKIP NSKIP is the no. sources to skip on restart * If NSKIP is omitted, program restarts at point of suspension * B register >0 if parameter follows GO command * * If (IAB(2)) 510, 510, 505 * 505 CALL RMPAR(IPRAM) NREC = NREC + IPRAM(1) * * On restart..... * 510 CALL ISSR(0) * Check length of time the program was suspended CALL EXEC (11, ITIME, IYEAR) UTAFT = FLOAT(ITIME(4))*60. + FLOAT(ITIME(3)) + !MINUTES * FLOAT(ITIME(2))/60. SUSTIM = UTAFT - UTBEF If (SUSTIM .LT. 0.) SUSTIM = SUSTIM + 1440. If (SUSTIM .GT. SSLIMT) then PRINT '(A1)', CHAR(14B) !Form feed PRINT '("Restarted at",2I5,"Day ",2I5)', (ITIME(L), * L=4,3,-1), ITIME(5), IYEAR PSUSPD = .TRUE. endif * * Check if program which interrupted this one changed parameters * in SHDATA and replace with values for this program if nec. * CALL CHFIL (IRN) * * Local set ICON = 1B + NOBORT CALL RNRQ (ICON, IRN, ISTAT, *850) C PRINT '("TNSTP locally sets RN ",I4)', IRN * * Replace S-reg value from before suspension CALL SWOUT (ISWIT) * GO TO 900 * * Error point 850 PRINT '("Error in SUSPD for ICON, IRN, ISTAT = ", K6, 2I5)', * ICON, IRN, ISTAT * 900 RETURN END * ********************************************************************* * * Subroutine change values on SHDATA if these were overwritten * during suspension * ********************************************************************* * $ALIAS RNRQ, NOABORT * SUBROUTINE CHFIL (IRN) * PARAMETER (MAXPRG = 10) * CHARACTER DATNAM*10, PRGNAM*6, DUMCHR*1, OBPCHR*108, * SHPCHR(MAXPRG)*108, OBPNM*6, SEGNAM*5 * LOGICAL OB3P4, OB6CM, OB13CM, OB18CM, ob2p5, ob4p5, * DUAL34, DUAL6, NADD13, NADD18, NOALC, nadd25, nadd45 * DATA NOBORT / 40000B /, DATNAM /'SHDATA::16'/, * PRGNAM /'TNSTP'/, * OB3P4 /.TRUE./, OB6CM /.TRUE./, OB13CM /.TRUE./, * OB18CM /.FALSE./, * ob2p5 / .FALSE. / , ob4p5 / .FALSE. /, * DUAL34/.TRUE./, DUAL6 /.TRUE./, NADD13 /.TRUE./, * NADD18/.FALSE./, * nadd25 / .false. / , nadd45 / .false. / * SEGNAM = 'CHFIL' * * Open, read and close file containing SCHEDULING parameters * Assign 110 to label NSTMT = 110 110 OPEN (10, file=DATNAM, iostat=ierr, err=820, status='OLD') * * Read file to preserve existing parms from other progs Assign 115 to label NSTMT = 115 115 READ (10,'(A108)', iostat=ierr, err=820) OBPCHR * NPROGS is the no of programs in schedule READ (OBPCHR(1:14),'(I2,A6,I6)', iostat=ierr, err=820) * NPROGS, OBPNM, LLRN READ (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), * K = 1,NPROGS) REWIND 10 ! Get to BOF for writing * If (OBPNM .NE. PRGNAM) then * If (IRN .NE. LLRN) then PRINT '((A10)," allocated new RN",(I6)," in place", * "of old",(I6))', OBPNM, LLRN, IRN IRN = LLRN endif * * Write info on this program to disc file, replacing other info * Assign 120 to label NSTMT = 120 120 WRITE (10, 1200, iostat=ierr, err=820) NPROGS, PRGNAM, * IRN, OB3P4, OB6CM, OB13CM, OB18CM, * ob2p5, ob4p5, * DUAL34, DUAL6, NADD13, NADD18, nadd25, nadd45 WRITE (10,'(A108)', iostat=ierr, err=820) (SHPCHR(K), * K = 1,NPROGS) * endif Assign 160 to label NSTMT = 160 160 CLOSE (10, iostat=ierr, err=820) * GO TO 900 * * Error handling * * 820 If (ierr .eq. 462) then PRINT '("Disc file ",(A10)," does not exist."/, * "Run SHPRM on other terminal to create it. ",/ * "Hit RETURN when done.", * " _")', DATNAM READ '(A1)', DUMCHR GO TO 110 else * Call ERMSG (ierr, NSTMT, SEGNAM, *900, k) GO TO label endif * 900 RETURN * 1200 FORMAT (I2, A6, I6, 12L2, 70X) END * * END$