C PROGRAM LATLIST 0001 C PREPARES OBSERVING LIST FOR LATITUDE OBSERVATIONS BY THE 0002 C HORREBOW-TALCOTT METHOD. 0003 C PROGRAM ASSUMES THE USE OF A WILD T4 UNIVERSAL THEODOLITE. 0004 C 0005 C ORDER OF INPUT DATA CARDS. 0006 C _________________________ 0007 C _________________________ 0008 C 0009 C (1) JOB CARD 0010 C 0011 C (2) THE FOLLOWING J C L CARDS (STARTING IN COLUMN ONE) 0012 C (THESE J C L ARE FOR SORTING THE UPDATED STARS IN ASCENDING R-A ORDER 0013 C //SORT EXEC SORT2314 0014 C //SORTOUT DD DSN=&&OUT,UNIT=SYSDA,SPACE=(TRK,(100,20)), 0015 C // DCB=(RECFM=FB,LRECL=80,BLKSIZE=800),DISP=(,PASS) 0016 C //SYSIN DD * 0017 C SORT FIELDS=(14,2,A,17,2,A,20,2,A),FOMAT=CH,SIZE=E2500 0018 C //SORTIN DD * 0019 C 0020 C (3) UPDATED STARS DECK FROM PROGRAM UPDATE. 0021 C SUFFICIENT TO COVER PERIOD OF OBSERVATION. 0022 C 0023 C (4) THE FOLLOWING J C L CARDS (STARTING IN COLUMN ONE) 0024 C // EXEC FORTGCG 0025 C //FORT.SYSIN DD * 0026 C 0027 C (5) THE PROGRAM LATLIST 0028 C 0029 C (6) THE FOLLOWING J C L CARDS (STARTING IN COLUMN ONE) 0030 C //GO.FT08F001 DD DSN=&&OUT,DISP=(OLD,DELETE),UNIT=SYSDA, 0031 C // VOL=REF=*.SORT.SORT.SORTOUT 0032 C 0033 C (7) STATION CARD. 0034 C 0035 C COLS. 1-16 STATION NAME. 0036 C COLS. 18-19 DEGREES OF LATITUDE (NEGATIVE SIGN FOR SOUTH) 0037 C COLS. 21-22 MINUTES OF LATITUDE. 0038 C COLS. 24-25 SECONDS OF LATITUDE. 0039 C COLS. 27-29 HOURS OF LONGITUDE (NEGATIVE SIGN FOR WEST). 0040 C COLS. 31-32 MINUTES OF LONGITUDE. 0041 C COLS. 34-35 SECONDS OF LONGITUDE. 0042 C COLS. 37-38 DAY OF OBSERVATION. 0043 C COLS. 40-41 MONTH OF OBSERVATION. 0044 C COLS. 43-46 YEAR OF OBSERVATION. 0045 C COLS. 48-55 EQUATORIAL VALUE OF MICROMETER IN SECONDS. 0046 C 0047 C (8) TIME CARD. 0048 C 0049 C COLS. 2-3 HOURS OF CIVIL TIME FOR BEGGINING OF OBSERVATION. 0050 C COLS. 5-6 MINUTES OF STARTING TIME. 0051 C COLS. 8-9 HOURS OF ENDING TIME. 0052 C COLS. 11-12 MINUTES OF ENDING TIME. 0053 C COLS. 14-15 ZONAL CORRECTION(HOURS) 0054 C 0055 C 0056 C NOTE - IF CARD IS BLANK AN OBSERVING LIST WILL BE MADE OUT OF ALL THE 0057 C INPUT UPDATED STARS DECK. 0058 C 0059 C (9) BLANK CARD TO TERMINATE PROGRAM. 0060 C 0061 C (10) THE FOLLOWING J C L CARDS (STARTING IN COLUMN ONE) 0062 C /* 0063 C // 0064 C 0065 C 0066 C 0067 C 0068 C*********************************************************************** 0069 IMPLICIT REAL * 8 (A-H,O-Z) 0070 REAL * 8 JD,LAMDA,LST(2) 0071 INTEGER STAR(100) 0072 DIMENSION R(100),D(100),FMAG(100),P(4),T(2) 0073 COMMON IP,MP,JP,ID,MO,IYEAR,NUPAGE,LINES 0074 COMMON R,D,FMAG,P,TMIN,TMAX,PHI,TWOPHI,N,STAR,NPAIR 0075 DATA PI,RHO,SOLSID/3.14159265358979D0,206264.80625D0,0.9972695664D 0076 10/ 0077 TMIN=1.D0/60.D0 0078 REWIND 8 0079 TMAX=1.D0/6.D0 0080 DMAX=20.D0/60.D0 0081 ZDMAX=60.D0 0082 TWOPI=PI*2.D0 0083 CENT=36525.D0 0084 NPAIR=0 0085 NUPAGE=0 0086 N=1 0087 C 0088 C READING STATION CARD-STATION NAME,LATITUDE,LONGITUDE,LOCAL DATE, 0089 C EQUATORIAL VALUE OF MICROMETER DRUM. 0090 C 0091 READ(5,1) P,IP,MP,JP,IL,ML,JL,ID,MO,IYEAR,DRUM 0092 1 FORMAT(4A4,3I3,I4,4I3,I5,F8.3) 0093 A=30.D0/DRUM 0094 CALL JULDAT(ID,MO,IYEAR,JD) 0095 IF(IL.LT.0.) GO TO 2 0096 LAMDA= ( IL+ML/60.D0+JL/3600.D0) 0097 GO TO 3 0098 2 LAMDA=-(-IL+ML/60.D0+JL/3600.D0) 0099 3 PHI=IP+MP/60.D0+JP/3600.D0 0100 TWOPHI=PHI*2.D0 0101 CALL TITLE 0102 C 0103 C READING TIME CARD-STARTING AND CLOSING TIME OF OBSERVATION, 0104 C ZONAL CORRECTION. 0105 C 0106 READ(5,4) IH1,MH1,IH2,MH2,IZH 0107 4 FORMAT(5I3) 0108 T(1)=IH1+MH1/60.D0 0109 T(2)=IH2+MH2/60.D0 0110 IF(T(1).EQ.T(2))GO TO 13 0111 IF(T(2).LT.T(1)) T(2)=T(2)+24.D0 0112 DT=IZH 0113 C 0114 C CONVERTING CIVIL TIME TO LAST. 0115 C 0116 DO 10 I=1,2 0117 UTC=T(I)+DT 0118 IF(UTC.LT.24.) GO TO 5 0119 UTC=UTC-24.D0 0120 JD=JD+1.D0 0121 5 IF(UTC.GT.0.) GO TO 6 0122 UTC=UTC+24.D0 0123 JD=JD-1.D0 0124 6 T1=JD/CENT 0125 GMSTO=6.64606555556D0+(8640184.542D0*T1+0.0929D0*T1* T1)/3600.D0 0126 IGMST=GMSTO/24.D0 0127 GMSTO=GMSTO-IGMST*24.D0 0128 GMST=GMSTO+UTC/SOLSID 0129 IF(GMST.LT.24.) GO TO 7 0130 GMST=GMST-24.D0 0131 7 LST(I)=GMST+LAMDA+24.D0 0132 8 IF(LST(I)-24.) 10,9,9 0133 9 LST(I)=LST(I)-24.D0 0134 GO TO 8 0135 10 CONTINUE 0136 C READING UPDATED STAR POSITIONS AND SEARCHING FOR STAR PAIRS. 0137 C SEARCH IS LIMITED TO WITHIN TEN MINUTES OF FIRST STAR IN A TEN 0138 C MINUTE BLOCK. 0139 13 READ(8,14) STAR(N),FMAG(N),IR,MR,JR,IC,MC,JC 0140 14 FORMAT(1X,I5,F6.2,3I3,5X,3I3) 0141 C 0142 C STAR TOO FAINT. 0143 C 0144 IF(FMAG(N).GT.7.)GO TO 13 0145 IF(STAR(N).EQ.0 ) GO TO 44 0146 R(N)=IR+MR/60.D0+JR/3600.D0 0147 IF(IC.LT.0 ) GO TO 15 0148 D(N)= IC+MC/60.D0+JC/3600.D0 0149 GO TO 16 0150 15 D(N)=-(-IC+MC/60.D0+JC/3600.D0) 0151 16 IF(T(1).EQ.T(2))GO TO 18 0152 IF(LST(1).GT.LST(2)) GO TO 17 0153 C 0154 C REJECT STARS NOT WITHIN TIME INTERVAL. 0155 C 0156 IF(R(N).LT.LST(1).OR.R(N).GT.LST(2)) GO TO 13 0157 GO TO 18 0158 17 IF(R(N).LT.LST(1).AND.R(N).GT.LST(2)) GO TO 13 0159 18 ZD=DABS(PHI-D(N)) 0160 IF(ZD-ZDMAX) 19 ,19,13 0161 19 IF(N-1) 20,20,21 0162 20 N=N+1 0163 GO TO 13 0164 21 DT=R(N)-R(1) 0165 C 0166 C TIME INTERVAL TOO LONG. 0167 C 0168 IF(DT.GT.TMAX) GO TO 22 0169 N=N+1 0170 GO TO 13 0171 22 QN=D(1)-PHI 0172 IF(QN) 33,23,23 0173 C 0174 C FIRST STAR IN BLOCK IS A NORTH STAR. 0175 C 0176 23 DO 31 I=2,N 0177 RFIX=R(1) 0178 DFIX=D(1) 0179 DT=R(I)-R(1) 0180 IF(DT.LT.TMIN) GO TO 31 0181 IF(DT.GT.TMAX) GO TO 31 0182 ZS=D(I)-PHI 0183 C 0184 C REJECT SOUTH STARS. 0185 C 0186 IF(ZS) 24,24,31 0187 24 DM=DABS(ZS+QN) 0188 IF(DM-DMAX) 25,25,31 0189 C 0190 C COMPUTE ZENITH DISTANCE AT TRANSIT. 0191 C 0192 25 ZNE=(D(1)-D(I))/2.D0 0193 ZNW=360.D0-ZNE 0194 DM=(TWOPHI-D(1)-D(I))*60.D0 0195 C COMPUTE MICROMETER SETTING. 0196 DMW=10.D0+A*DM 0197 DME=20.D0-DMW 0198 NPAIR=NPAIR+1 0199 KT=1 0200 26 IR=RFIX 0201 AR=(RFIX-IR)*60.D0 0202 MR=AR 0203 JR=(AR-MR)*60.D0 0204 IC=DFIX 0205 AC=(DFIX-IC)*60.D0 0206 MC=AC 0207 JC=(AC-MC)*60.D0 0208 MC=IABS(MC) 0209 IF(JC.GT.30) MC=MC+1 0210 IF(KT.GT.1) GO TO 29 0211 IZ=ZNE 0212 ZN=(ZNE-IZ)*60.D0 0213 MZ=ZN 0214 ZN=(ZN-MZ)*60.D0 0215 IF(ZN.GT.30.) MZ=MZ+1 0216 JZ=ZNW 0217 ZN=(ZNW-JZ)*60.D0 0218 MJ=ZN 0219 ZN=(ZN-MJ)*60.D0 0220 IF(ZN.GT.30.) MJ=MJ+1 0221 IF(LINES.GT.12)CALL TITLE 0222 C 0223 C PRINT PAIRS. 0224 C 0225 IQ=IR 0226 MQ=MR 0227 JQ=JR 0228 IO=IC 0229 MK=MC 0230 27 WRITE(6,28) NPAIR,STAR(1),FMAG(1),IQ,MQ,JQ,IO,MK,JZ,MJ,DMW,IZ,MZ, 0231 1DME 0232 28 FORMAT(' ',25X,I3,I8,F6.1,I4,2I3,I4,I3,3X,'N',I5,I3,'(W)',F6.1,'(W 0233 1)',/,I69,I3, '(E)',F6.1,'(E)') 0234 RFIX=R(I) 0235 DFIX=D(I) 0236 KT=KT+1 0237 GO TO 26 0238 29 WRITE(6,30) STAR(I),FMAG(I),IR,MR,JR,IC,MC 0239 30 FORMAT(' ',I36,F6.1,I4,2I3,I4,I3,3X,'S',/) 0240 LINES=LINES+1 0241 31 CONTINUE 0242 32 GO TO 42 0243 C 0244 C FIRST STAR IN BLOCK IS A SOUTH STAR. 0245 C 0246 33 ZS=-QN 0247 DO 41 I=2,N 0248 RFIX=R(1) 0249 DFIX=D(1) 0250 DT=R(I)-R(1) 0251 C 0252 C TIME INTERVAL TOO SHORT. 0253 C 0254 IF(DT.LT.TMIN) GO TO 41 0255 IF(DT.GT.TMAX) GO TO 41 0256 QN=D(I)-PHI 0257 C REJECT NORTH STARS. 0258 IF(QN) 41,34,34 0260 34 DM=DABS(ZS-QN) 0261 C 0262 C ZENITH DISTANCES DIFFERENCE TOO LARGE. 0263 C 0264 IF(DM-DMAX) 35,35,41 0265 C 0266 C COMPUTE ZENITH DISTANCE AT TRANSIT. 0267 C 0268 35 ZSW=(D(I)-D(1))/2.D0 0269 ZSE=360.D0-ZSW 0270 DM=(TWOPHI-D(1)-D(I))*60.D0 0271 C COMPUTE MICROMETER SETTING. 0272 DMW=10.D0+A*DM 0273 DME=20.D0-DMW 0274 NPAIR=NPAIR+1 0275 KT=1 0276 36 IR=RFIX 0277 AR=(RFIX-IR)*60.D0 0278 MR=AR 0279 JR=(AR-MR)*60.D0 0280 IC=DFIX 0281 AC=(DFIX-IC)*60.D0 0282 MC=AC 0283 JC=(AC-MC)*60.D0 0284 MC=IABS(MC) 0285 IF(JC.GT.30) MC=MC+1 0286 IF(KT.GT.1) GO TO 39 0287 IZ=ZSE 0288 ZN=(ZSE-IZ)*60.D0 0289 MZ=ZN 0290 ZN=(ZN-MZ)*60.D0 0291 IF(ZN.GT.30.) MZ=MZ+1 0292 JZ=ZSW 0293 ZN=(ZSW-JZ)*60.D0 0294 MJ=ZN 0295 ZN=(ZN-MJ)*60.D0 0296 IF(ZN.GT.30.) MJ=MJ+1 0297 IF(LINES.GT.12)CALL TITLE 0298 C 0299 C PRINT PAIRS. 0300 C 0301 IQ=IR 0302 MQ=MR 0303 JQ=JR 0304 IO=IC 0305 MK=MC 0306 37 WRITE(6,38) NPAIR,STAR(1),FMAG(1),IQ,MQ,JQ,IO,MK,JZ,MJ,DMW,IZ,MZ, 0307 1DME 0308 38 FORMAT(' ',25X,I3,I8,F6.1,I4,2I3,I4,I3,3X,'S',I5,I3,'(W)',F6.1,'(W 0309 1)',/,I69,I3, '(E)',F6.1,'(E)') 0310 RFIX=R(I) 0311 DFIX=D(I) 0312 KT=KT+1 0313 GO TO 36 0314 39 WRITE(6,40) STAR(I),FMAG(I),IR,MR,JR,IC,MC 0315 40 FORMAT(' ',I36,F6.1,I4,2I3,I4,I3,3X,'N',/) 0316 LINES=LINES+1 0317 41 CONTINUE 0318 42 DO 43 I=2,N 0319 J=I-1 0320 STAR(J)=STAR(I) 0321 FMAG(J)=FMAG(I) 0322 R(J)=R(I) 0323 D(J)=D(I) 0324 43 CONTINUE 0325 GO TO 13 0326 44 WRITE(6,45) 0327 45 FORMAT('1') 0328 STOP 0329 END 0330 SUBROUTINE TITLE 0331 IMPLICIT REAL * 8(A-H,O-Z) 0332 INTEGER STAR(100) 0333 DIMENSION R(100),D(100),FMAG(100),P(4),T(2) 0334 COMMON IP,MP,JP,ID,MO,IYEAR,NUPAGE,LINES 0335 COMMON R,D,FMAG,P,TMIN,TMAX,PHI,TWOPHI,N,STAR,NPAIR 0336 NUPAGE=NUPAGE+1 0337 LINES=1 0338 WRITE(6,1) P,IP,MP,JP,ID,MO,IYEAR,NUPAGE 0339 1 FORMAT('1',//,10X,'LATITUDE OBSERVING LIST FOR ',4A4,'-LAT(',3I3,' 0340 1)',' DATE',I3,'-',I2,'-',I4,14X,'PAGE',I2,//,26X,'PAIR',3X, 0341 2'STAR',3X,'MAG',3X,'RIGHT',4X,'DECL.',2X,'STAR',2X,'Z.D.',4X,'MICR 0342 3O',/,27X,'NO',5X,'NO',8X,'ASCENSION',9X,'POS.',10X,'METER',/) 0343 RETURN 0344 END 0345 SUBROUTINE JULDAT(IDAY,MO,IYEAR,JD) 0346 IMPLICIT REAL * 8(A-H,O-Z) 0347 REAL *8 JD,JC 0348 INTEGER MON(12)/31,28,31,30,31,30,31,31,30,31,30,31/ 0349 C DAY ZERO IS 1900 JAN 0.5 U.T. 0350 C CHECK IF YEAR IS 1900 0351 JY=1900 0352 C CORRECTIONS FOR YEAR LATER THAN 1900 0353 C (1) ASSUMING NO LEAP YEARS. (IYEAR-JY)*365 0354 C (2)LEAP YEAR CORRECTIONS (IYEAR-JY+3)/4 0355 ID=(IYEAR-JY)*365+(IYEAR-JY+3)/4 0356 IY=1600 0357 INT=-2 0358 1 J=0 0359 3 IY=IY+100 0360 IF((IYEAR-IY).LE.0) GO TO 200 0361 J=J+1 0362 IF(J.EQ.4) GO TO 1 0363 INT=INT+1 0364 GO TO 3 0365 200 MON(2)=28 0366 Y=IYEAR 0367 X=IYEAR/4 0368 Z=IYEAR/400 0369 C=IYEAR/100 0370 IF(X.NE.Y/4) GO TO 500 0371 IF(C.NE.Y/100) GO TO 100 0372 IF(Z.NE.Y/400) GO TO 500 0373 100 MON(2)=29 0374 500 IM=MO-1 0375 ND=0 0376 IF(IM.LE.0) GO TO 400 0377 DO 300 I=1,IM 0378 300 ND=ND+MON(I) 0379 400 JD=ND+IDAY+ID-INT-0.5D0 0380 RETURN 0381 END 0382