FTN77,S $FILES 2,2 PROGRAM OBPLN (3,80) ********************************************************************* * * PROGRAM TO OBSERVE ANY PLANET WHEN SCHEDULED AT 4 CONTINUUM FREQ. * Based on OB114 and TNFPC. * * Modified from OB174 1994/06/10 UPDATE VERSION BELOW * ********************************************************************* * PARAMETER (NFRQ = 4) * CHARACTER CPLACE(11)*2, NAMRFL*10, PRGNAM*5, PLANETS(9)*8, * CSORSNM*8, CFILNAM*6 * LOGICAL AOK, START, CHK, HKEEP, PROB, NEXT, FIRE, * RPTFQ, BADTRK, DUALBM, WVTB, CALSRS, IFBRK, * NO3P4, HYPFLT * 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), * IRETPM(5) * REAL FNOFS(NFRQ), HPOFS(NFRQ), * RAOFS(NFRQ), DEOFS(NFRQ), WAVE(NFRQ), * TUFLUX(NFRQ), BMSEP(NFRQ), * ERWAV(10), ERSQAV(10), MEDTB, MEDVM, * SFLUX(11), SERR(11), DVM(11) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, BADTRK, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * EQUIVALENCE (REG,IAB(1)), * (RAP, IANG(1)), (DECP, IANG(3)), * (CSORSNM,SORSNM(2)), (CFILNAM,FILNAM(1)) * * 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) * RATLT, DETLT is the offset of the 18cm FEED when hyperbola is TILTED * 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 PLday. * * DATA WAVE / 6.0, 3.4, 13.0, 18.0 /, * FNOFS / 0.18, 0.230, 0.4, 0.595 /, * HPOFS / 0.075, 0.048, 0.162, 0.247 /, * RAOFS / 0.177, 0.132, 0.071, 0.070 /, * RATLT / 0.096 /, * DEOFS / -0.230, -0.566, 0.413, 1.700 /, * DETLT / 0.904 /, * BMSEP / 0.288, 0.254, 0.0, 0.0 /, * TUFLUX/ 24.0, 175.0, 35.0, 140.0 /, * ISIZE / 20 /, ITYPE / 3 /, ISECU / 0 /, ICR / 15 /, * RESFIL / 2HPL, 2H00, 2H /, * FILNAM / 2HPL, 2HAN, 2HET /, * DPRC2 / 2HDP, 2HRC, 2H2 /, * HALIM / 5.9 /, LU / 7 /, * NFIRST / 1 /, PRGNAM / 'OBPLN' /, * PLANETS / 'MERCURY', 'VENUS', 'EARTH', 'MARS', 'JUPITER', * 'SATURN', 'URANUS', 'NEPTUNE', 'PLUTO' / * CALL RMPAR(IRETPM) ! Pick up parameters from SCHDL * * Save initial S-Register state * ISWSV = SWIN(O) * * Planet is determined from first IRETPM * SORSNM(1) = 2H IF (IRETPM(1) .GE. 1 .AND. IRETPM(1) .LE. 9) then CSORSNM = PLANETS(IRETPM(1)) CFILNAM = PLANETS(IRETPM(1))(1:6) else CSORSNM = '*ILLEGAL*' endif * * Second IRETPM determines 13/18cm repeats * IF (IRETPM(2).LT.0) then * * If negative, disable 13/18 completely (set bits 2,3) with 0 repeats * ISWIT = SWIN(0) ISWIT = ISWIT .OR. 000014B CALL SWOUT (ISWIT) IRETPM(2) = 0 endif * CALL FSYSU (LU, LU) * 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 bits 9,10,15 are not set from previous PROGS * ISWIT = SWIN(0) ISWIT = ISWIT .AND. 074777B CALL SWOUT (ISWIT) * * Ensure Noise Diodes are off so calibration works * CALL EXEC (2, 113B, 0, 1, 3, 3) * * Set HP3336 synthesiser away from 22 MHz to reduce inteference * CALL F3336(33,23.6D0) * * Print suitable Program Header * CALL EXEC(11,ITIME,IYEAR) WRITE (LU,1000) ITIME(5),IYEAR 1000 FORMAT(//3X,"SCHEDULED PLANETS PROGRAM (OBPLN) : DAY ",I3,",",I4 * /3X,48"=" * //3X," Version <980911.0701>" * //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.0 cm readings" * /22X," 2 ON to suspend 13.0cm readings" * /22X," 3 ON to suspend 18.0cm readings" * //22X," 9 ON to repeat current FREQ." * /22X," 10 ON to repeat current SOURCE " * //22X," 15 ON to END PROGRAM.",//) * * Check Hyperbola is untilted and correctly focussed * CALL CHKHYP(HYPFLT) IF (.NOT. HYPFLT) GO TO 100 * * Hyperbola is tilted, set bits 0, 1 & 2 to skip 3.4, 6.0 and 13cm * PRINT *,' Observations only possible at 18cm !' ISWIT = SWIN(0) ISWIT = ISWIT .OR. 000007B CALL SWOUT (ISWIT) * * Change 18cm Beam Offsets to TILTED values * RAOFS(4) = RATLT DEOFS(4) = DETLT * * Confirm planet ID info is suitable * 100 IF (CSORSNM .EQ. '*ILLEGAL*' ) then WRITE (LU,3140) 3140 FORMAT(/3X,"Illegal planet specified",//) GO TO 900 elseif (CSORSNM .EQ. 'EARTH') then WRITE (LU,3145) 3145 FORMAT(/3X,"Here's looking at you, kid !!!",//) GO TO 900 else WRITE (LU,3150) CSORSNM 3150 FORMAT(/3X,"Attempting Observation of ",A10,//) endif * * 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, (RESFIL(L), L=1,3) 8400 FORMAT(/" FMGR ERROR ",I4," in opening ",3A2) GO TO 900 * * Create file. 820 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) * NSORS = 0 CALSRS = .FALSE. START = .TRUE. * * START OF LOOP FOR EACH SOURCE. * 500 CONTINUE * * Repeat observation IRETPM(2) times * IF (NSORS .GT. IRETPM(2)) GO TO 900 IF (.NOT. START) then * * Repeats only at 13cm and/or 18cm ( ie. set Bits 0,1 ) * ISWIT = SWIN(0) ISWIT = ISWIT .OR. 000003B CALL SWOUT (ISWIT) endif NSORS = NSORS + 1 * * Obtain current co-ordinates of planetary source * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 START = .FALSE. * * 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 * WRITE (LU,5900) ISTH, ISTM, ISTS 5900 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 * IF (HA .LE. HALIM) GO TO 590 * * Else... * WRITE (LU,5950) NSORS, HA, HALIM 5950 FORMAT(/,"Source",I4," HA",F6.2," exceeds limit", * F6.2," dec hr") WRITE (LU,5960) 5960 FORMAT("GO TO NEXT SOURCE") * GO TO 500 * 590 IF (HA .GT. -HALIM) GO TO 600 PRINT '(/"Source",I4," at RA",F6.2," HA",F6.2, * " not risen yet. END.")', NSORS, RAHRS, HA WRITE(LU,5960) * GO TO 500 * * Print source file information and headers for each track. * 600 WRITE (LU,6000) 6000 FORMAT(/1X," NO. SOURCE RA DEC ") WRITE (LU,6100) NSORS, (SORSNM(J), J=1,5), RAP, DECP 6100 FORMAT(1X,I3,3X,5A2,1X,F8.3,1X,F8.3) * * Print HEADERS for each track * WRITE (LU,6200) 6200 FORMAT(//8X," FREQ PLACE START TRACK AT",12X,"FLUX"/ * 8X," USED(cm) TRACKED RA",7X,"DEC",6X,"TIME",8X,"(Jy)" * /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 CALL OBSOK * DO 700 I=1,NFRQ * * Bits 0, 1, 2, 3 set for skip 3.4, 6.0, 13.0, 18.0 cm. meas * ISWIT = SWIN(0) ISWIT = ISWIT .AND. 000017B GO TO (702, 701, 703, 704) 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 * * Set up HP8662 synthesizer for 18cm * CALL F8662(38,266.5D0,16.0) * 711 DUALBM = ((WAVE(I) .EQ. 3.4) .OR. (WAVE(I) .EQ. 6.0)) * * Calculate antenna coords for each track and then track source. * 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 * * Check if BIT 15 has been set * IF(ISSW(15) .LT. 0) GO TO 900 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT NORTH FIRST NULL OF (A) BEAM * Calculate coordinates: * TRA = ONRA + SEPFAC TDEC= ONDEC + FNOFS(I) KPLACE = 2HFN * FIRE = .TRUE. 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT NORTH HALF POWER POINT OF (A) BEAM. * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT ONSOURCE POINT OF (A) BEAM ie. at antenna beam peak. * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT SOUTH HALF POWER POINT OF (A) BEAM * Calculate coordinates: * 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 * * If using single beam system, skip to tracking at FIRST NULL. * * For DUAL BEAM, track at point between the two beams, and at * 2 other FIRST NULL points. * IF ( .NOT. DUALBM ) GO TO 650 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT SOUTH FIRST NULL OF (A) BEAM * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT MID POINT BETWEEN THE TWO BEAMS * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT NORTH FIRST NULL OF B BEAM * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT NORTH HALF POWER POINT OF B BEAM * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT ONSOURCE POINT OF (A) BEAM ie. at antenna beam peak. * Calculate coordinates: * 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 * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT SOUTH HALF POWER POINT OF B BEAM * Calculate coordinates: * 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 * 650 CONTINUE * * Re-calculate current position factors * CALL PLANET(LU,FILNAM,RAP,DECP,IERR) IF (IERR .NE. 0) GO TO 900 * Add in beam offsets ONRA = RAP + RAOFS(I)/COS(DECP*0.017453293) ONDEC= DECP + DEOFS(I) * Correct RA values for COS(DEC) affect CORDEC = COS(ONDEC * 0.017453293) SEPFAC = (BMSEP(I)/2.)/CORDEC * * TRACK AT SOUTH FIRST NULL OF (B) BEAM * Calculate coordinates: * 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 * * Write fluxes etc from each position to file RESFIL * CALL WRTFL (NAMRFL, CPLACE, SFLUX, SERR, DVM, * NL, HKEEP, WVTB, RPTFQ, BADTRK, *900,k) * * Write out used value of noise tube in DVM units PRINT '("Noise tube ",F12.4," DVM units")', 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 10 set for repeat of current source. * IF ( ISSW(10) .LT. 0) GO TO 690 * * Go back to run for next source. GO TO 500 * 900 CONTINUE * 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) * * Reset S-Register to original and Return parameters * CALL SWOUT (ISWSV) CALL PRTN (IRETPM) CALL EXEC (6) * 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(11)*2, NAMRFL*10 * LOGICAL NEXT, PROB, HKEEP, FIRE, RPTFQ, WVTB, CALSRS, BADTRK * 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(11), SERR(11), DVM(11) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, BADTRK, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * NUMTRK = NUMTRK + 1 * WRITE (LU,1000) WAVE(I), KPLACE, TRA, TDEC 1000 FORMAT(9X, F5.1, 6X, 1A2, 4X, F7.3, 2X, F7.3,"_") * CALL TRACK (4, TRA, TDEC, .TRUE., .TRUE.) CALL EXEC (11,TIMON) WRITE (LU,1100) TIMON(4), TIMON(3), TIMON(2) 1100 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, BADTRK, k,*) * CHARACTER NAMRFL*10, SEGNAM*5, CPLACE(11)*2, FCHAR*42 * LOGICAL HKEEP, WVTB, RPTFQ, BADTRK * REAL SFLUX(11), SERR(11), DVM(11) * * 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, BADTRK, DVM(ILN) 165 CONTINUE * 1100 FORMAT (L1, L1, A2, G12.6, G12.6, 2L1, 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, 'WRTFL', *900, k) GO TO label * 900 RETURN k END * ********************************************************************* * BLOCK DATA * ********************************************************************* * LOGICAL HKEEP, PROB, NEXT, FIRE, RPTFQ, BADTRK, 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, BADTRK, 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 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(11)*2, NAMRFL*10 * LOGICAL HKEEP, PROB, RPTFQ, BADTRK, 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(11), SERR(11), DVM(11), TEMP(4) * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVM, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, BADTRK, 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, F10.6, I2, L2, F12.6) * else if (WVTB) then * * Read temp and humidity nad structure temperatures * CALL RTHUM (ATEMP, HUM) CALL RSTMP (TEMP) * * Write wavelength and ave. tube DVM value. * WRITE (50, 1200, iostat=ierr, err=820) * HKEEP, WVTB, WAVE(I), MEDTB, * TBDEV, ATEMP, HUM, (TEMP(K),K=1,4) 1200 FORMAT(L1, L1, F6.1, 2G12.6, 6F6.1) * 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, 'WINFO', *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 $ALIAS/POINT/,NOALLOCATE * SUBROUTINE FLUX (LU, TUFLUX, WAVE) * LOGICAL NEXT, FTUBE, FIRE, HKEEP, PROB, RPTFQ, BADTRK, CALSRS * INTEGER IBUF(4), HASL, SORSNM(5), IDCB(272), * ITIME(5), ERSORS(10), * LOGCLS, CMDCLS, CMDRSN * REAL TUFLUX(1), JYDVM, WAVE(1), DIGVM(651), MEDTB, * MEDVAL, ERWAV(10), ERSQAV(10), PREVTB(4), TBNOM(4), * PREVER(4), MEDIAN, * HALIM, DECLIM, HAERR, DECERR, REALHA, RELDEC * COMMON / CBOTH / SORSJY, ERROR, MEDTB, TBDEV, MEDVAL, NEXT, FIRE, * HKEEP, PROB, SORSNM, KPLACE, IDCB, NSORS, * I, ITIME, IYEAR, RPTFQ, BADTRK, ERSORS, ERWAV, * KERR, ERSQAV, CALSRS, IDCBS, TUBNET * COMMON / POINT / LOGCLS, CMDCLS, CMDRSN, HALIM, DECLIM, * HAERR, DECERR, REALHA, RELDEC * COMMON /DOUT1/ ISERVO * DATA NSMPL / 650 /, NTSAM / 650 /, !Remember change DIGVM * TBNOM / -.0564, -.0123, .0202, .0520 / * 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 * * 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 * BADTRK = .FALSE. * * Loop to read DVM and average NSAM samples. * DO 200 NN = 1,NSAM * READ (35,*) RDVM * ERRHA = HAERR If (ABS(ERRHA) .GE. .010) BADTRK = .TRUE. * * 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 = TOTDVM / COUNT SQAV = SUMSQ/COUNT AVDSQ = AVDVM * AVDVM * DIFF = SQAV - AVDSQ If (DIFF .LT. 0.) DIFF = 0. STDEV = SQRT( DIFF ) STDEV = STDEV/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) = 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 ( 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 MJG 1987 dec 21 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(1X,G12.4),/ * "COUNT, TLEVL", 2(1X,G12.4),/ * "MEDIAN, MEDTB, MEDVAL, TUBNET ", * 4(1X,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 PRINT '(F6.3,"+-",F5.3)', SORSJY, ERROR * 988 FIRE = .FALSE. RETURN END * ********************************************************************* * * 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 * ********************************************************************** * Check hyperbola focus and tilt matches standards for this system * * returns : * * FAULT logical*2 false if focus & tilt within tolerance * * otherwise set true * ********************************************************************** * SUBROUTINE CHKHYP (FAULT) * REAL*4 STDFOCUS, STDTILT, SUBFOCUS, SUBTILT LOGICAL FAULT CHARACTER HYPMES*11, FOCMES*11, TILTMES*9, NOTMES*4 * DATA TOLERANCE / 0.8 /, STDFOCUS / 8.0 /, STDTILT / -0.67 /, & HYPMES /'HYPERBOLA '/, & FOCMES /'FOCUSED TO '/, & TILTMES /'TILTED TO'/, & NOTMES /' NOT'/ * FAULT = .FALSE. CALL RHYP (SUBFOCUS, SUBTILT) IF (ABS(SUBFOCUS-STDFOCUS) .GT. TOLERANCE) THEN FAULT = .TRUE. PRINT *,HYPMES//FOCMES,SUBFOCUS,NOTMES,STDFOCUS END IF IF (ABS(SUBTILT-STDTILT) .GT. TOLERANCE) THEN FAULT = .TRUE. PRINT *,HYPMES//TILTMES,SUBTILT,NOTMES,STDTILT END IF * RETURN END * ********************************************************* * include &OBSOK::16 ! Observing alarm reset include &RTHUM::16 ! Temperature and Humidity include &RSTMP::16 ! Structure temperatures include &RHYP::16 ! Hyperbola readout include &PLNET::16 ! Planet coord reader include &F3336::16 ! HP3336 setting routine include &F8662::16 ! HP8662 setting routine * *********************************************************