C***********************************************************************00000030 C* *00000040 C* PROGRAM 'TERRADD' ADDS NEW OBSERVED DISTANCES OR AZIMUTHS TO *00000050 C* FILE SE.GEODESY.DIST&AZ. THE PROGRAM *00000060 C* CHECKS THE FILE TO SEE IF THERE IS ALREADY A DISTANCE OR AZIMUTH *00000070 C* FOR THE LINE, IF SO, THE NEW OBSERVATION IS ADDED TO THAT RECORD,IF*00000080 C* NOT, A NEW RECORD IS PUT ON. *00000090 C* *00000100 C* INPUT DATA: (TO BE READ FROM DATA CARD) *00000110 C* ICODE = 0 = DISTANCE *00000120 C* = 1 = AZIMUTH *00000130 C* NSTN1 = FROM STATION GEODETIC NUMBER *00000140 C* IDAL = DEGREES OF ASTRO LONGTITUDE NSTN1 *00000150 C* IMAL = MINUTES OF ASTRO LONGTITUDE NSTN1 *00000160 C* SAL = SECONDS OF ASTRO LONGTITUDE NSTN1 *00000170 C* NSTN2 = TO STATION GEODETIC NUMBER *00000180 C* IDAZ = DEGREES OF ASTRO AZIMUTH FROM NSTN1 TO NSTN2 *00000190 C* IMAZ = MINUTES OF ASTRO AZIMUTH FROM NSTN1 TO NSTN2 *00000200 C* SAZ = SECONDS OF ASTRO AZIMUTH FROM NSTN1 TO NSTN2 *00000210 C* DIST = DISTANCE FROM NSTN1 TO NSTN2 (METRES) *00000220 C* IDT = DISTANCE CODE 0 = SEA LEVEL DIST *00000230 C* 1 = SPATIAL DISTANCE *00000240 C* 2 = GEODESIC DISTANCE *00000250 C* IIT = INSTRUMENT CODE B = BASELINE *00000260 C* G = GEODIMETER *00000270 C* T = TELLUROMETER *00000280 C* S = SATELLITE *00000290 C* C = CHAINED (TRAVERSE) *00000300 C* W = GEODETIC CODE FOR COMPUTING VARIANCE OF DISTANCE*00000310 C* IF ICODE=0 *00000320 C* = VARIANCE OF AZIMUTH IN ARC-SECONDS SQUARED IF *00000330 C* ICODE=1 *00000340 C* *00000350 C* NOTE 1: EACH DATA CARD SHOULD CONTAIN ONLY ONE NEW OBSERVATION *00000360 C* NOTE 2: THE DATA CARDS ARE REPEATED UNTIL ALL OBSERVATIONS ARE *00000370 C* ADDED NO SPECIAL CARD IS NEEDED AT THE END, THE *00000380 C* PROGRAM STOPS ITSELF *00000390 C* NOTE 3: THE APPARENTLY RANDOM ORDER OF THE INPUT FORMAT IS TO *00000400 C* CONFORM TO GEODETIC SURVEY OF CANADA DATA CARDS FOR *00000410 C* DISTANCE OBSERVATIONS AND SHOULD NOT BE CHANGED. *00000420 C* *00000430 C* *00000440 C***********************************************************************00000450 C 00000460 C 00000470 REAL*8 DIST,ASTLON,ASTAZ 00000480 C 00000490 C PUT THE VARIABLES TO BE PASSED IN COMMON 00000500 C 00000510 COMMON /INPUT/DIST,ASTLON,ASTAZ,SIGMA2,ICODE,IDT,IIT 00000520 DEFINE FILE 12(700,145,L,M) 00000530 C 00000540 C READ IN A NEW DATA CARD--IF DATA EXHAUSTED STOP EXECUTION 00000550 C 00000560 10 READ(5,1000,END=40)ICODE,NSTN1,IDAL,IMAL,SAL,NSTN2,IDAZ,IMAZ,SAZ, 00000570 1 DIST,IDT,IIT,W 00000580 C 00000590 C CHECK IF THE OBSERVATION IS A DISTANCE OR AZIMUTH AND BRANCH 00000600 C ACCORDINGLY 00000610 C 00000620 IF(ICODE.EQ.1)GO TO 20 00000630 C 00000640 C COMPUTE VARIANCE OF DISTANCE FROM GEODETIC SURVEY FORMULA 00000650 C 00000660 SIGMA2=SQRT(W) 00000670 GO TO 30 00000680 C 00000690 C COMPUTE THE ASTRO LONGTITUDE AND AZIMUTH IN RADIANS, DEFINE THE 00000700 C VARIANCE OF THE AZIMUTH 00000710 C 00000720 20 CALL ARCRAD(IDAL,IMAL,SAL,ASTLON) 00000730 CALL ARCRAD(IDAZ,IMAZ,SAZ,ASTAZ) 00000740 SIGMA2=W 00000750 30 CALL PUTERR(NSTN1,NSTN2) 00000760 C 00000770 C WRITE OUT AN APPROPRIATE MESSAGE AS TO WHAT HAS HAPPENED TO THE 00000780 C OBSERVATION 00000790 C 00000800 IF(ICODE.EQ.1)WRITE(6,1010)NSTN1,NSTN2 00000810 IF(ICODE.EQ.2)WRITE(6,1020)NSTN1,NSTN2 00000820 IF(ICODE.EQ.3)WRITE(6,1030)NSTN1,NSTN2 00000830 IF(ICODE.EQ.4)WRITE(6,1040)NSTN1,NSTN2 00000840 C 00000850 C GO BACK AND READ IN A NEW OBSERVATION 00000860 C 00000870 GO TO 10 00000880 40 STOP 00000890 1000 FORMAT(I1,T7,I8,T17,I4,I2,F7.4,T32,I7,T41,I3,I2,F7.4,T58,F12.4, 00000900 1 T70,I1,A1,T74,F7.4) 00000910 1010 FORMAT('0',5X,'A NEW RECORD HAS BEEN CREATED FOR THE DISTANCE FROM00000920 . STATION',I9,' TO STATION',I9) 00000930 1020 FORMAT('0',5X,'A NEW DISTANCE HAS BEEN ADDED TO THE RECORD FOR STA00000940 .TION',I9,' TO STATION',I9) 00000950 1030 FORMAT('0',5X,'A NEW RECORD HAS BEEN CREATED FOR THE AZIMUTH FROM 00000960 .STATION',I9,' TO STATION',I9) 00000970 1040 FORMAT('0',5X,'A NEW AZIMUTH HAS BEEN ADDED TO THE RECORD FOR STAT00000980 .ION',I9,' TO STATION',I9) 00000990 END 00001000 SUBROUTINE PUTERR(NSTN1,NSTN2) 00001010 C 00001020 C SUBROUTINE PUTERR WRITES ON THE TERRESTRIAL DATA FILE NEW DISTANCES 00001030 C OR AZIMUTHS -- USED WITH PROGRAM TERRADD 00001040 C 00001050 C 00001060 REAL*8 DIST1,DIST2,CORDIS,ALON,AAZ1,AAZ2,ZENDIS,ZDISC,DIST, 00001070 . ASTLON,ASTAZ 00001080 C 00001090 C PUT IN COMMON THE VARIABLES TO BE ADDED AND A CODE 00001100 C 00001110 COMMON/INPUT/DIST,ASTLON,ASTAZ,SIGMA2,ICODE,IDT,IIT 00001120 C 00001130 C SET UP A COUNTER FOR THE NUMBER OF MASHES 00001140 C 00001150 J=0 00001160 C 00001170 C PERFORM HASH 00001180 C 00001190 M1=NSTN1 00001200 10 IF(M1.LT.100000)GO TO 20 00001210 M1=M1/10+MOD(M1,100000) 00001220 GO TO 10 00001230 20 M2=NSTN2 00001240 30 IF(M2.LT.100000)GO TO 40 00001250 M2=M2/10+MOD(M2,100000) 00001260 GO TO 30 00001270 C 00001280 C PERFORM THE MASH 00001290 C 00001300 40 MASH1=M1/1000*100+M2/1000 00001310 MASH2=MOD(M1,1000)*100+MOD(M2,1000) 00001320 NSTN=MASH1*10000+MASH2 00001330 MASH=MOD(NSTN,697) 00001340 IF(MASH.EQ.0)MASH=700 00001350 C 00001360 C READ ALL INFORMATION FROM THE ADDRESS MASH AND CHECK IF IT IS THE 00001370 C DESIRED RECORD 00001380 C 00001390 50 READ(12'MASH,1000)N1,N2,DIST1,SDDIS1,IDC1,IIT1,DIST2,SDDIS2,IDC2, 00001400 1 IIT2,ALON,AAZ1,SAAZ1,AAZ2,SAAZ2 00001410 C 00001420 C CHECK IF THE RECORD IS FOR THE LINE NSTN1 TO NSTN2--IF SO BRANCH 00001430 C 00001440 IF(N1.EQ.NSTN1.AND.N2.EQ.NSTN2)GO TO 60 00001450 C 00001460 C CHECK IF THE RECORD HAS A 0 FOR NSTN1--IF SO BRANCH TO WRITE THE NEW 00001470 C OBSERVATION ON THIS RECORD 00001480 C 00001490 IF(N1.EQ.0)GO TO 100 00001500 C 00001510 C RE-DO THE MASH AND CHECK FOR THE COUNTER GREATER THAN 200 THE MASH 00001520 C EQUAL TO 0 -- IF COUNTER > 200 STOP LOOKING IF NOT TRY AGAIN 00001530 C 00001540 MASH=MOD((NSTN1+MASH),691) 00001550 J=J+1 00001560 IF(MASH.EQ.0)MASH=700 00001570 IF(J.GT.200)GO TO 130 00001580 GO TO 50 00001590 C 00001600 C CHECK IF OBSERVATION IS A DISTANCE OR AZIMUTH IF AZIMUTH BRANCH 00001610 C 00001620 60 IF(ICODE.EQ.1)GO TO 80 00001630 C 00001640 C CHECK IF THE TWO FIELDS FOR DISTANCES ON THE RECORD ARE OCCUPIED, IF 00001650 C THEY ARE WRITE OUT A MESSAGE THAT THE DISTANCE IS NOT ADDED 00001660 C 00001670 IF(DIST1.NE.0.0.AND.DIST2.NE.0.0)WRITE(6,1010)NSTN1,NSTN2 00001680 ICODE=0 00001690 C 00001700 C CHECK IF THE DISTANCE 1 FIELD IS EMPTY IF NOT BRANCH 00001710 C 00001720 IF(DIST1.NE.0.0)GO TO 70 00001730 C 00001740 C PLACE THE NEW OBSERVATIONS IN THE APPROPRIATE VARIABLES AND BRANCH 00001750 C TO WRITE THEM ON THE RECORD 00001760 C 00001770 DIST1=DIST 00001780 SDDIS1=SIGMA2 00001790 IDC1=IDT 00001800 IIT1=IIT 00001810 ICODE=2 00001820 GO TO 120 00001830 C 00001840 C CHECK IF THE SECOND DISTANCE FIELD IS EMPTY IF NOT BRANCH 00001850 C 00001860 70 IF(DIST2.NE.0.0)GO TO 120 00001870 C 00001880 C PUT THE NEW OBSERVATIONS IN THE APPROPRIATE VARIABLES AND BRANCH TO 00001890 C WRITE OUT THE RECORD 00001900 C 00001910 DIST2=DIST 00001920 SDDIS2=SIGMA2 00001930 IDC2=IDT 00001940 IIT2=IIT 00001950 ICODE=2 00001960 GO TO 120 00001970 C 00001980 C CHECK IF BOTH AZIMUTH FIELDS ARE OCCUPIED IF SO WRITE OUT A MESSAGE 00001990 C THAT THE NEW OBSERVATION WILL NOT BE ADDED 00002000 C 00002010 80 IF(AAZ1.NE.0.0.AND.AAZ2.NE.0.0)WRITE(6,1020)NSTN1,NSTN2 00002020 ICODE=0 00002030 C 00002040 C CHECK IF THE FIRST AZIMUTH FIELD IS OCCUPIED IS SO BRANCH 00002050 C 00002060 IF(AAZ1.NE.0.0)GO TO 90 00002070 C 00002080 C PLACE THE NEW OBSERVATIONS IN THE APPROPRIATE VARIABLES AND BRANCH TO00002090 C WRITE OUT THE RECORD 00002100 C 00002110 AAZ1=ASTAZ 00002120 ALON=ASTLON 00002130 SAAZ1=SIGMA2 00002140 ICODE=4 00002150 GO TO 120 00002160 C 00002170 C CHECK IF THE SECOND AZIMUTH FIELD IS BLANK IF NOT BRANCH 00002180 C 00002190 90 IF(AAZ2.NE.0.0)GO TO 120 00002200 C 00002210 C PLACE THE NEW OBSERVATIONS IN THE NEW VARIABLES HERE A MESSAGE MUST00002220 C BE WRITTEN OUT THE THE ASTRO LONGTITUDE IS ALREADY DEFINED AND WILL 00002230 C NOT BE CHANGED 00002240 C 00002250 AAZ2=ASTAZ 00002260 SAAZ2=SIGMA2 00002270 ICODE=4 00002280 CALL RADARC(ALON,IDAL,IMAL,SAL) 00002290 WRITE(6,1030)NSTN1,NSTN2,IDAL,IMAL,SAL,NSTN1 00002300 1030 FORMAT('0',5X,'WARNING FOR THE AZIMUTH FROM',I9,' TO',I9,' AN A00002310 .STRO LONGTITUDE OF',2X,I4,2X,I2,2X,F7.4//6X,'FOR STATION',I9,' IS00002320 .ALREADY ON THE FILE THE NEW VALUE HAS NOT BEEN ADDED') 00002330 GO TO 120 00002340 C 00002350 C CHECK IF THE NEW OBSERVATION IS A DISTANCE OR AZIMUTH IF AZIMUTH 00002360 C BRANCH 00002370 C 00002380 100 IF(ICODE.EQ.1)GO TO 110 00002390 C 00002400 C PLACE THE NEW OBSERVATION ON THE RECORD AND BRANCH TO WRITE IT OUT 00002410 C 00002420 DIST1=DIST 00002430 SDDIS1=SIGMA2 00002440 IIT1=IIT 00002450 IDC1=IDT 00002460 ICODE=1 00002470 GO TO 120 00002480 C 00002490 C PLACE THE NEW OBSERVATIONS IN THE APPROPRIATE VARIABLES AND THEN 00002500 C BRANCH TO WRITE IT OUT 00002510 C 00002520 110 AAZ1=ASTAZ 00002530 ALON=ASTLON 00002540 SAAZ1=SIGMA2 00002550 ICODE=3 00002560 C 00002570 C WRITE THE NEW RECORD ON THE FILE AND RETURN 00002580 C 00002590 120 WRITE(12'MASH,1000)NSTN1,NSTN2,DIST1,SDDIS1,IDC1,IIT1,DIST2,SDDIS200002600 1 ,IDC2,IIT2,ALON,AAZ1,SAAZ1,AAZ2,SAAZ2 00002610 RETURN 00002620 C 00002630 C WRITE OUT A MESSAGE THE A RECORD HAS NOT BEEN FOUND FOR THE NEW DATA 00002640 C 00002650 130 WRITE(6,1040)NSTN1,NSTN2 00002660 RETURN 00002670 1000 FORMAT(2I9,2(F13.5,F8.5,I1,A1),F19.16,2(F19.16,F8.5)) 00002680 1010 FORMAT('0',5X,'WARNING THE RECORD FOR STATION',I9,' TO STATION',00002690 . I9,' ALREADY HAS 2 DISTANCES'//6X,'THE NEW OBSERVATION WIL00002700 .L NOT BE ADDED') 00002710 1020 FORMAT('0',5X,'WARNING THE RECORD FOR STATION',I9,' TO STATION',00002720 . I9,' ALREADY HAS 2 AZIMUTHS'//6X,'THE NEW OBSERVATION WILL00002730 . NOT BE ADDED') 00002740 1040 FORMAT('0','** THE SET OF OBSERVATIONS FROM ',I9,' TO',I9, 00002750 . 'CANNOT BE FOUND **') 00002760 END 00002770 C 00002780 C SUBROUTINE 'RADARC' CONVERTS RADIANS TO DEGREES MINUTES AND 00002790 C SECONDS. FOR NEGATIVE ANGLES ONLY THE LEFTMOST NONZERO VALUE IS 00002800 C NEGATIVE (EGS. -50,15,30.5 ; 0,-35,30.0 ; 0,0,-50.5) 00002810 C 00002820 C NOTE: THE 0.0005 VALUE IS TO GUARD AGAINST ROUNDOFF 00002830 C 00002840 C INPUT: A = RADIAN VALUE OF ANGLE (REAL*8) 00002850 C 00002860 C OUTPUT: I = DEGREES (INTEGER) 00002870 C J = MINUTES (INTEGER) 00002880 C S = SECONDS (REAL*4) 00002890 C 00002900 SUBROUTINE RADARC(A,I,J,S) 00002910 DOUBLE PRECISION A,SEC,AD,AJ,RHO, SIGN 00002920 DATA RHO/206264.8062470963D0/ 00002930 C 00002940 C CHECK SIGN OF 'A' -- SET SIGN=-1 IF NEGATIVE AND CONVERT 'A' TO 00002950 C POSITIVE VALUE 00002960 C 00002970 SIGN=1.0D0 00002980 IF(A.LT.0.0)SIGN=-1.0D0 00002990 IF(SIGN.LT.0.0)A=-A 00003000 C 00003010 C CONVERT 'A' TO ARCSECONDS 00003020 C 00003030 SEC=A*RHO+0.0005D0 00003040 C 00003050 C FIND INTEGER DEGREES 00003060 C 00003070 I=SEC/3600.0D0 00003080 AD=I 00003090 C 00003100 C FIND INTEGER MINUTES 00003110 C 00003120 J=SEC/60.0D0-AD*60.0D0 00003130 AJ=J 00003140 C 00003150 C FIND REAL*4 SECONDS 00003160 C 00003170 S=SEC-AD*3600.0D0-AJ*60.0D0-0.0005D0 00003180 C 00003190 C SET LEFTMOST VALUE NEGATIVE IF SIGN=-1 00003200 C 00003210 IF(I.NE.0)GO TO 20 00003220 IF(J.EQ.0)GO TO 10 00003230 J=J*SIGN 00003240 GO TO 30 00003250 10 S=S*SIGN 00003260 GO TO 30 00003270 20 I=I*SIGN 00003280 C 00003290 C CONVERT 'A' BACK TO NEGATIVE IF SIGN=-1 00003300 C 00003310 30 IF(SIGN.LT.0.0)A=-A 00003320 RETURN 00003330 END 00003340 C***********************************************************************00003350 C* *00003360 C* S U B R O U T I N E A R C R A D *00003370 C* *00003380 C***********************************************************************00003390 C 00003400 C 00003410 C SUBROUTINE 'ARCRAD' CONVERTS DEGREES MINUTES AND SECONDS TO 00003420 C RADIANS. FOR NEGATIVE VALUES OF THE ANGLE ONLY THE LEFTMOST NON-ZERO 00003430 C VALUE IS NEGATIVE. (EGS. -30,15,30.0;0,-25,15.5;0,0,-37.2) 00003440 C 00003450 C INPUT: I = DEGREES (INTEGER) 00003460 C J = MINUTES (INTEGER) 00003470 C S = SECONDS (REAL*4) 00003480 C 00003490 C OUTPUT: RADS = ANGLE IN RADIANS (REAL*8) 00003500 C 00003510 C 00003520 SUBROUTINE ARCRAD(I,J,S,RADS) 00003530 REAL*8 RADS,DABS,DFLOAT,DBLE,SIGN,RH0/57.29577951308233D0/ 00003540 C 00003550 C CHECK FOR POSITIVE OR NEGATIVE ANGLES 00003560 C 00003570 SIGN=1.0D0 00003580 IF(I.LT.0.OR.J.LT.0.OR.S.LT.0.0)SIGN=-1.0D0 00003590 C 00003600 C CHECK FOR ANGLE OF ZERO -- IF ZERO SET RADS EXACTLY 0.0D0 00003610 C 00003620 IF(I.EQ.0.AND.J.EQ.0.AND.S.EQ.0.0)GO TO 10 00003630 C 00003640 C COMPUTE RADIAN VALUE 00003650 C 00003660 RADS=((DABS(DFLOAT(I))+DABS(DFLOAT(J)/60.0D0)+DABS(DBLE(S)/3600.0D00003670 10))/RH0)*SIGN 00003680 RETURN 00003690 10 RADS=0.0D0 00003700 RETURN 00003710 END 00003720