C PROGRAMME POLAZ2 00004980 C***********************************************************************00004990 C PROGRAMME POLAZ2 00005000 C PROGRAMME COMPUTES AZIMUTH FROM POLARIS OBSERVATION AT ANY 00005010 C HOUR ANGLE. 00005020 C 00005030 C ORDER OF INPUT DATA CARDS. 00005040 C 00005050 C (1) STATION CARD. 00005060 C 00005070 C COLS. 1-16 STATION NAME. 00005080 C COLS. 18-20 DEGREES OF LATITUDE (NEGATIVE SIGN FOR SOUTH). 00005090 C COLS. 22-23 MINUTES OF LATITUDE. 00005100 C COLS. 25-29 SECONDS OF LATITUDE (2 DECIMALS). 00005110 C COLS. 31-33 HOURS OF LONGITUDE (NEGATIVE SIGN FOR WEST) 00005120 C COLS. 35-36 MINUTES OF LONGITUDE. 00005130 C COLS. 38-42 SECONDS OF LONGITUDE. 00005140 C COLS. 44-59 REFERENCE OBJECT. 00005150 C 00005160 C PROGRAM ACCEPTS POSITIVE ECCENTRIC ANGLES ONLY. TO CONVERT 00005170 C NEGATIVE ANGLES TO POSITIVE ADD 360 DEGREES. 00005180 C 00005190 C COLS. 61-63 DEGREES OF ECCENTRIC ANGLE. 00005200 C COLS. 65-66 MINUTES OF ECCENTRIC ANGLE. 00005210 C COLS. 68-72 SECONDS OF ECCENTRIC ANGLE (2 DECIMALS). 00005220 C COLS. 74-80 STATION ELEVATION IN METRES (1 DECIMAL). 00005230 C 00005240 C (2) INSTRUMENT CARD. 00005250 C 00005260 C COLS. 1-8 INSTRUMENT NAME. 00005270 C COLS. 9-14 INSTRUMENT NUMBER. 00005280 C COLS. 15-20 LEVEL SENSITIVITY (2 DECIMALS). 00005290 C COLS. 22-23 FIRST DAY OF OBSERVATION. 00005300 C COL. 24 SLASH SIGN (/). 00005310 C COLS. 25-26 SECOND DAY OF OBSERVATION. 00005320 C COLS. 28-29 MONTH. 00005330 C COLS. 31-34 YEAR. 00005340 C COLS. 36-51 OBSERVER'S NAME. 00005350 C COLS. 52-67 RECORDER'S NAME. 00005360 C COLS. 68-73 X-COORDINATE OF MEAN POLE IN SECONDS (2 DECIMALS) 00005370 C COLS. 74-79 Y-COORDINATE OF MEAN POLE IN SECONDS (2 DECIMALS) 00005380 C 00005390 C (3) POLARIS CARD FOR BEGINNING OF SET. 00005400 C 00005410 C COLS. 1-5 STAR NUMBER. 00005420 C COLS. 6-11 STAR MAGNITUDE (2 DECIMALS). 00005430 C COLS. 13-14 HOURS OF RIGHT ASCENSION. 00005440 C COLS. 16-17 MINUTES OF RIGHT ASCENSION. 00005450 C COLS. 19-24 SECONDS OF RIGHT ASCENSION (3 DECIMALS). 00005460 C COLS. 26-28 DEGREES OF DECLINATION. 00005470 C COLS. 30-31 MINUTES OF DECLINATION. 00005480 C COLS. 33-37 SECONDS OF DECLINATION (2 DECIMALS) 00005490 C COLS. 39-43 DIURN. ABR. COR. IN RIGHT ASCENSION (3 DECIMALS). 00005500 C COLS. 44-51 DIURN. ABR. COR. IN DECLINATION (3 DECIMALS) 00005510 C COLS. 53-54 HOURS OF CLOCK TIME. 00005520 C COLS. 56-57 MINUTES OF CLOCK TIME. 00005530 C COLS. 59-64 SECONDS OF CLOCK TIME (3 DECIMALS). 00005540 C COLS. 66-80 CLOCK CORRECTION IN SECONDS(3 DECIMALS) 00005550 C 00005560 C (4) POLARIS CARD FOR END OF SET. 00005570 C 00005580 C NOTE THAT CARDS (3) AND (4) ARE THE OUTPUT OF PROGRAM 'UPDATE'. 00005590 C 00005600 C (5) OBSERVATION CARDS. 00005610 C 00005620 C COLS. 1-4 DEGREES OF HOR. CIRCLE READING TO R.O. 00005630 C COLS. 6-7 MINUTES OF HOR. CIRCLE READING TO R.O. 00005640 C COLS. 9-13 SECONDS OF HOR. CIRCLE READING TO R.O. (2 DECIMALS).00005650 C COLS. 15-17 DEGREES OF HOR. CIRCLE READING TO POLARIS. 00005660 C COLS. 19-20 MINUTES OF HOR. CIRCLE READING TO POLARIS. 00005670 C COLS. 22-26 SECONDS OF HOR. CIRCLE READINGS TO POLARIS(2 D'MALS)00005680 C COLS. 28-29 HOURS OF CLOCK TIME - FIRST FACE. 00005690 C COLS. 31-32 MINUTES OF CLOCK TIME - FIRST FACE. 00005700 C COLS. 34-37 SECONDS OF CLOCK TIME - FIRST FACE(1 DECIMAL) 00005710 C COLS. 39-40 HOURS OF CLOCK TIME - SECOND FACE. 00005720 C COLS. 42-43 MINUTES OF CLOCK TIME - SECOND FACE. 00005730 C COLS. 45-48 SECONDS OF CLOCK TIME - SECOND FACE (1 DECIMAL) 00005740 C COLS. 50-53 WEST END OF BUBBLE (1 DECIMAL). 00005750 C COLS. 55-58 EAST END OF BUBBLE (1 DECIMAL). 00005760 C COLS. 60-63 WEST END OF BUBBLE (1 DECIMAL). 00005770 C COLS. 65-68 EAST END OF BUBBLE (1 DECIMAL). 00005780 C 00005790 C (6) BLANK CARD TO INDICATE OF SET OF OBSERVATIONS. 00005800 C 00005810 C (7) BLANK CARD TO INDICATE OF ONE NIGHT'S OBSERVA3IONS OTHERWISE 00005820 C REPEAT FROM (3). 00005830 C 00005840 C (8) BLANK CARD TO TERMINATE PROGRAM OTHERWISE REPEAT FROM (2). 00005850 C 00005860 C OUTPUT - AZIMUTH FROM EACH OBSERVATION AND FINAL AZIMUTH AFTER 00005870 C CORRECTIONS HAVE BEEN APPLIED. 00005880 C***********************************************************************00005890 C 00005900 IMPLICIT REAL *8(A-H,O-Z) 00005910 INTEGER BLANK/' '/,S1 00005920 REAL * 8 LAMDA,CC(2) 00005930 DIMENSION AZ(100),V(100),IREJ(100),CRA(2),CDEC(2),CT(2),CDDEC(2) 00005940 REJ1=3.D0 00005950 REJ2=3.D0 00005960 PI=3.14159265358979D0 00005970 RHO=206264.80625D0 00005980 DEGRAD=180.D0/PI 00005990 TWOPI=PI*2. 00006000 REST=REJ1/RHO 00006010 C 00006020 C READ STATION CARD - NAME,LAT,LONG,R.O.,ECCENTRICITY,HT(METERS). 00006030 C 00006040 1 READ(5,2) S1,S2,S3,S4,ILATD,ILATM,SECLAT,LONGH,LONGM,SECLON,R1,R2,00006050 1R3,R4,IECD,IECM,SECEC,HT 00006060 2 FORMAT(4A4,2(1X,2I3,F6.2),1X,4A4,1X,2I3,F6.2,1X,F7.1) 00006070 CALL ARCRAD(ILATD,ILATM,SECLAT,PHI) 00006080 CALL ARCRAD(LONGH,LONGM,SECLON,LAMDA) 00006090 LAMDA=LAMDA*15.D0 00006100 CALL ARCRAD(IECD,IECM,SECEC,ECCEN) 00006110 J=0 00006120 KT=0 00006130 C 00006140 C READ INSTRUMENT CARD - NAME,NUMBER,LEVEL VALUE,LOCAL DATE 00006150 C OBSERVER,RECORDER,COORDINATES OF THE MEAN POLE (IN SECONDS). 00006160 C 00006170 3 READ(5,4) C1,C2,NUMT, BS,IDAY1,IDAY2,MO,IYEAR,O1,O2,O3,O4,Q1,Q2,Q300006180 1,Q4,XP,YP 00006190 4 FORMAT(2A4,I6,F6.3,I3,1X,I2,I3,I5,1X,8A4,2F6.2) 00006200 BV=BS/4.D0 00006210 IF(IYEAR.EQ.0) GO TO 100 00006220 J=J+1 00006230 IF(J.GT.1) GO TO 20 00006240 WRITE(6,9) S1,S2,S3,S4,ILATD,ILATM,SECLAT,LONGH,LONGM,SECLON,R1,R200006250 1,R3,R4 00006260 9 FORMAT('1',15X,'AZIMUTH BY POLARIS AT ANY HOUR ANGLE',//,19X,'STAT00006270 1ION',7X,4A4,/,19X,'(LAT)',9X,2I3,F6.2,/,19X,'(LONG)',8X,2I3,F6.2,/00006280 2,19X,'R.O.',10X,4A4) 00006290 20 WRITE(6,21) IDAY1,IDAY2,MO,IYEAR 00006300 21 FORMAT(//,20X,'DATE',3X,I2,'/',I2,'-',I2,'-',I5) 00006310 WRITE(6,12) O1,O2,O3,O4,Q1,Q2,Q3,Q4 00006320 12 FORMAT(' ',18X,'OBSERVER',6X,4A4,/,19X,'RECORDER',6X,4A4) 00006330 WRITE(6,10) C1,C2,NUMT,BS 00006340 10 FORMAT(' ',18X,'INSTRUMENT',4X,2A4,' NO',I7,/,19X,'LEVEL VALUE',3X00006350 1,F5.3,2X,'SEC/DIV',//,10X,'UNCORRECTED',3X,'DISLEVELMENT',3X, 00006360 2'CURVATURE',3X,'D.ABR.',5X,'CORRECTED',/,5X,'NO',5X,'AZIMUTH',8X, 00006370 3'(SECS)',8X,'(SECS)',4X,'(SECS)',5X,'AZIMUTH') 00006380 C 00006390 C READING UPDATED POSITION OF POLARIS FROM 'UPDATE' CARDS 00006400 C 00006410 65 DO 5 I=1,2 00006420 READ(5,64)IPOL,FM,IP,MP,SP,IL,ML,SL,DRA,DDEC,IH,IM,SI,CC(I) 00006430 64 FORMAT( I5,F6.2,2I3,F7.3,I4,I3,F6.2,2F7.3 ,2I3,F7.3,F15.3) 00006440 IF(IPOL.EQ.0) GO TO 3 00006450 CC(I)=CC(I)/3600.D0 00006460 CRA(I)=(IP*3600.D0+MP*60.D0+SP)*15.D0/RHO 00006470 CDEC(I)=(IL*3600.D0+ML*60.D0+SL) /RHO 00006480 CDDEC(I)=DDEC 00006490 CT(I)=IH+IM/60.D0+SI/3600.D0 00006500 5 CONTINUE 00006510 C 00006520 C READ OBSERVATION CARD - H.C.R. OF R.O.,H.C.R. OF POLARIS 00006530 C TIME(FIRST FACE),TIME(SECOND FACE) LEVEL READINGS. 00006540 C 00006550 7 READ(5,8) IROD,MRO,SECRO,IPOLD,MPOL,SECPOL,IF1H,MF1,SECF1,IF2H,MF200006560 1,SECF2,W1,E1,W2,E2 00006570 IF(IROD.EQ.0.AND.IPOLD.EQ.0) GO TO 65 00006580 8 FORMAT(2(I4,I3,F6.2),2(2I3,F5.1),4F5.1) 00006590 KT=KT+1 00006600 HRO=((IROD*60+MRO)*60+SECRO)/RHO 00006610 HPOL=((IPOLD*60+MPOL)*60+SECPOL)/RHO 00006620 TF1=IF1H+MF1/60.+SECF1/3600.D0 00006630 TF2=IF2H+MF2/60.+SECF2/3600.D0 00006640 IF(TF1.GT.TF2) TF2=TF2+24.D0 00006650 TM=(TF1+TF2)/2.D0 00006660 IF(TM.GT.24.) TM=TM-24.D0 00006670 RATE=(TM-CT(1))/(CT(2)-CT(1)) 00006680 RA=CRA(1)+(CRA(2)-CRA(1))*RATE 00006690 DEC=CDEC(1)+(CDEC(2)-CDEC(1))*RATE 00006700 DDEC=CDDEC(1)+(CDDEC(2)-CDDEC(1))*RATE 00006710 AST=(TM+CC(1)+RATE*(CC(2)-CC(1)))*15.D0/DEGRAD 00006720 DTO=(TF2-TF1) 00006730 IF(DTO.LT.0.) DTO=DTO+24.D0 00006740 T=DTO*15.D0/(DEGRAD*4.D0) 00006750 H=(AST-RA) 00006760 Z=DARCOS(DSIN(DEC)*DSIN(PHI)+DCOS(DEC)*DCOS(H)*DCOS(PHI)) 00006770 AZP=DATAN(DSIN(H)/(DSIN(PHI)*DCOS(H)-DCOS(PHI)*DTAN(DEC))) 00006780 IF(AZP.LT.0.) AZP=AZP+TWOPI 00006790 CURVE=-2.*DSIN(T)*DSIN(T)*DTAN(AZP)*RHO 00006800 DDEC=0.3198D0*DCOS(PHI)*DCOS(AZP)/DSIN(Z) 00006810 DA=(DABS(W1-W2)-DABS(E1-E2))*BV/DTAN(Z) 00006820 AZP=AZP+HRO-HPOL 00006830 IF(AZP.LE.0.) AZP=AZP+TWOPI 00006840 CALL ARCS(AZP,IDEG,MIN,SEC) 00006850 WRITE(6,14) KT,IDEG,MIN,SEC 00006860 14 FORMAT(' ',I6,2X,2I3,F7.3) 00006870 AZ(KT)=AZP+(DDEC+CURVE-DA)/RHO+TWOPI 00006880 17 IF(AZ(KT)-TWOPI) 61,16,16 00006890 16 AZ(KT)=AZ(KT)-TWOPI 00006900 GO TO 17 00006910 61 CALL ARCS(AZ(KT),IDEG,MIN,SEC) 00006920 DA=-DA 00006930 WRITE(6,23) DA,CURVE,DDEC,IDEG,MIN,SEC 00006940 23 FORMAT('+',F32.3,F13.3,F10.3,I6,I3,F7.3) 00006950 18 CONTINUE 00006960 Z=Z*DEGRAD 00006970 AZP=AZP*DEGRAD 00006980 GO TO 7 00006990 C 00007000 C COMPUTING MEAN AZIMUTH 00007010 C 00007020 100 DO 31 I=1,KT 00007030 31 IREJ(I)=0 00007040 WRITE(6,66) 00007050 66 FORMAT('1',19X,'AZIMUTH AFTER APPLICATION OF REJECTION TESTS.',/00007060 1/,33X,'AZIMUTH',7X,'RES(S)',/) 00007070 C 00007080 C REJECTING BLUNDERS 00007090 C 00007100 33 SUM=0. 00007110 N=0 00007120 DO 25 I=1,KT 00007130 IF(IREJ(I).EQ.1) GO TO 25 00007140 26 SUM=SUM+AZ(I) 00007150 N=N+1 00007160 25 CONTINUE 00007170 IF(N.GT.0) GO TO 28 00007180 GO TO 6 00007190 28 XMEAN=SUM/N 00007200 K=0 00007210 SUM=0. 00007220 DO 30 I=1,KT 00007230 IF(IREJ(I).EQ.1) GO TO 30 00007240 V(I)=XMEAN-AZ(I) 00007250 REJ=15.D0/RHO-DABS(V(I)) 00007260 IF(REJ.LT.0.) GO TO 47 00007270 SUM=SUM+V(I)*V(I) 00007280 GO TO 30 00007290 47 IREJ(I)=1 00007300 K=K+1 00007310 30 CONTINUE 00007320 IF(K.GT.0) GO TO 33 00007330 C 00007340 C APPLYING THE THREE MINUTES TEST. 00007350 C 00007360 DO 70 I=1,KT 00007370 IF(IREJ(I).EQ.1) GO TO 70 00007380 V(I)=AZ(I)-XMEAN 00007390 REJ=REST-DABS(V(I)) 00007400 IF(REJ.LT.0.) GO TO 71 00007410 SUM=SUM+V(I)*V(I) 00007420 GO TO 70 00007430 71 IREJ(I)=1 00007440 K=K+1 00007450 70 CONTINUE 00007460 IF(K.GT.0) GO TO 33 00007470 C=N 00007480 NN=N-1 00007490 IF(NN.GT.0) GO TO 36 00007500 6 AHT=0. 00007510 APOL=0. 00007520 STDS=0. 00007530 STDM=0. 00007540 C=1.D0 00007550 GO TO 11 00007560 36 STDS=DSQRT(SUM/NN) 00007570 RES1=REJ2*STDS 00007580 K=0 00007590 SUM=0. 00007600 DO 48 I=1,KT 00007610 IF(IREJ(I).EQ.1) GO TO 48 00007620 REJ=RES1-DABS(V(I)) 00007630 IF(REJ.GT.0.) GO TO 48 00007640 IREJ(I)=1 00007650 K=K+1 00007660 48 CONTINUE 00007670 IF(K.GT.0) GO TO 33 00007680 APOL=-(XP*DSIN(LAMDA)+YP*DCOS(LAMDA))/(DCOS(PHI)*RHO) 00007690 11 DO 38 I=1,KT 00007700 CALL ARCS(AZ(I),IDEG,MIN,SEC) 00007710 IF(I.GT.1) GO TO 22 00007720 22 WRITE(6,24) I,IDEG,MIN,SEC 00007730 24 FORMAT(' ',24X,I3,2X,2I3,F7.3) 00007740 41 V(I)=V(I)*RHO 00007750 WRITE(6,45) V(I) 00007760 IF(IREJ(I).EQ.1) GO TO 56 00007770 45 FORMAT('+',44X,F8.3) 00007780 GO TO 38 00007790 56 WRITE(6,27) 00007800 27 FORMAT('+',53X,'REJECTED') 00007810 38 CONTINUE 00007820 200 STDM=STDS/DSQRT(C)*RHO 00007830 WRITE(6,29) 00007840 29 FORMAT(' ',///) 00007850 CALL ARCS(XMEAN,ID,MI,SE) 00007860 CALL ARCS(APOL,IP,MP,SP) 00007870 AZIMTH= XMEAN+ECCEN+APOL 00007880 55 IF(AZIMTH-TWOPI) 60,53,53 00007890 53 AZIMTH=AZIMTH-TWOPI 00007900 GO TO 55 00007910 60 CALL ARCS(AZIMTH,IDAZ,MAZ,SAZ) 00007920 WRITE(6,63) 00007930 63 FORMAT('1',39X,'SUMMARY',/,40X,'*******',//) 00007940 WRITE(6,34) ID,MI,SE,IECD,IECM,SECEC,IP,MP,SP,IDAZ,MAZ,SAZ,STDM 00007950 34 FORMAT(' ',26X,'ARITHMETIC MEAN =',I5,I3,F7.3,/,27X,'ECC. CORR00007960 1ECTION =',I5,I3,F7.3,/,27X,'POLAR MOTION CORR. =',I5,I3,F7.3,00007970 2//,27X,'FINAL AZIMUTH =',I5,I3,F7.3,/,27X,'STD. DEVIATION 00007980 3 =',8X,'+',F6.3,/,56X,'-',//) 00007990 WRITE(6,300) 00008000 300 FORMAT('1') 00008010 STOP 00008020 END 00008030