IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE DIMENSION GC(200) 98 FORMAT(I8,3F11.2) 99 FORMAT(' ',I8,3F11.2) 100 FORMAT(6A8,I8) 101 FORMAT('1',6A8,I8) 102 FORMAT(4I6,I4,I6,3I3,F9.6,F5.0) 103 FORMAT('0',9I6,F12.6,F6.0) 104 FORMAT(' ',4(F15.2,F13.2)) 105 FORMAT(I6,F5.0,F2.0,F3.1,F9.2,F5.1) 106 FORMAT(' ',I6,F10.0,F4.0,F5.1,F16.2,F10.1) 107 FORMAT('0ANGLE ERROR IS',I5,I4,F5.1,' EQUIV NO OF ANGLES',F6.1) 108 FORMAT('0STATION X COORDINATE Y COORDINATE') 109 FORMAT('0',I7,2F14.2) 110 FORMAT(' ',F21.2,F14.2) 111 FORMAT('0CLOSING AZIMUTH AND DISTANCE IS',I5,I4,F5.1,F12.2) 112 FORMAT(' ERROR PER ANGLE IN SECONDS',F6.1,' CORRECTION PER ANGLE 1IN SECONDS',F6.1) 113 FORMAT(I6,I2,F3.0,F2.0,F3.1,F9.2) 114 FORMAT(' ',2I6,2F4.0,F5.1,F16.2) 115 FORMAT('0PRECISION 1/',I8) 116 FORMAT(' LENGTH PRECISION 1/',I8) 117 FORMAT(' LATERAL PRECISION 1/',I8) 118 FORMAT(' AZIMUTH SHIFT',F7.1) 119 FORMAT(' AZIMUTH DISTANCE FACTOR') 120 FORMAT('0',I8,I3,F5.1,F11.2,F12.6) 121 FORMAT('0',I7,2F14.2) 122 FORMAT('0N.B. COORDINATES ARE NOT ADJUSTED') 123 FORMAT(7I6,F12.6) 124 FORMAT('0',7I6,F12.6) 128 FORMAT('0STATION X COORDINATE Y COORDINATE RADIUS') 129 FORMAT('0',I7,2F14.2,F10.2) 133 FORMAT(11I6) 134 FORMAT('0FROM STA',I7,' TO STA',I7,' STRAIGHT LINE AZIMUTH AND DIS 1TANCE IS',I5,I3,F5.1,F9.2) 135 FORMAT('0STA',I7,' IS',F7.2,' FEET RIGHT OF LINE AT CHG',F9.2) 136 FORMAT('0STA',I7,' IS',F7.2,' FEET LEFT OF LINE AT CHG',F10.2) 137 FORMAT('0AREA IS',F11.0,' SQ FT OR',F9.2,' ACRES') 138 FORMAT('0STATION X COORDINATE Y COORDINATE STATION X COORDINATE Y 1 COORDINATE AZIMUTH DISTANCE') 139 FORMAT(' ',I7,2F13.2,I9,2F13.2,I5,I3,F5.1,F10.2) 140 FORMAT('0STATION STATION ARC AZIMUTH DISTANCE RADIUS' 1) 141 FORMAT('0',I7,I8,F9.2,I5,I3,F5.1,F10.2,F10.2) 152 FORMAT(2I6,2(F6.0,F6.0,F6.1)) 158 FORMAT(4I6,F12.2) 159 FORMAT(2I6,F12.2,4F6.2) 160 FORMAT('0') 162 FORMAT(5I6,F12.6,2F6.0,F6.1,F6.2) 163 FORMAT('0',5I6,F12.6,F6.0,F4.0,F5.1,F8.2) 164 FORMAT(I6,I10) Z=0 RAD=57.2957795 C READ AND STORE KNOWN COORDINATES 19 READ(5,98)ISB,XB,YB,DIST IF(ISB)18,200,18 18 WRITE(6,99)ISB,XB,YB,DIST CALL DISK(ISB,1,XB,YB,DIST) GO TO 19 C READ HEADER CARD WITH CONTROL NUMBER 200 READ(5,100)HDR,M8 WRITE(6,101)HDR,M8 WRITE(6,160) GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14),M8 3 CALL INTRCT GO TO 200 6 CALL CURV1 GO TO 200 10 CALL RESEX GO TO 200 12 CALL INTR2 GO TO 200 7 CALL CURV2 GO TO 200 C CONTROL NUMBER IS 'ONE' DO CLOSED TRAVERSES 1 READ(5,102)IBR,ISB,ISE,IER,N,IP,KK,KN,KP,FCT,CRMX 1 READ(5,102)IBR,ISB,ISE,IER,N,IP,KK,KN,KP,FCT,CRMX IF(FCT)95,96,95 96 FCT=1. 95 WRITE(6,103)IBR,ISB,ISE,IER,N,IP,KK,KN,KP, FCT,CRMX GO TO(20,21,21),KN 20 CALL DISK(IBR,2,XBR,YBR,Z) CALL DISK(ISB,2,XB,YB,Z) CALL DISK(ISE,2,XE,YE,Z) CALL DISK(IER,2,XER,YER,Z) WRITE(6,104)XBR,YBR,XB,YB,XE,YE,XER,YER M=N+1 SUM=0. DO 201 I=1,M READ(5,105)IS(I),A1,A2,A3,HD(I) ,GC(I) WRITE(6,106)IS(I),A1,A2,A3,HD(I),GC(I) SUM=SUM+1.+GC(I) 201 HA(I)=A1+A2/60.+A3/3600. IF(CRMX)93,94,93 94 CRMX=20. 93 CRMX=CRMX/3600. RAZ1=BG(XB-XBR,YB-YBR) DO 202 I=1,M AZ5=RAZ1-180. IF(AZ5)203,204,204 203 AZ5=AZ5+360. 204 AZ(I)=AZ5+HA(I)-360. IF(AZ(I))205,206,206 205 AZ(I)=AZ(I)+360. 206 RAZ1=AZ(I) 202 CONTINUE F=SUM F1=DSQRT(SUM) CORA=BG(XER-XE,YER-YE)-AZ(M) IF(CORA)900,901,901 900 CORA2=CORA*(-1.) IF(CORA2.LT.358.)GO TO 902 CORA2=360.-CORA2 GO TO 902 901 CORA2=CORA 902 IF(CORA2-F1*CRMX)207,208,208 208 X1(M)=XE Y1(M)=YE DO 209 I=1,N K=M-I AZ5=AZ(K)+CORA-360. IF(AZ5)210,212,212 210 AZ5=AZ5+360. IF(AZ5)211,212,212 211 AZ5=AZ5+360. 212 X1(K)=X1(K+1)-HD(K)*FCT*DSIN(AZ5/RAD) 209 Y1(K)=Y1(K+1)-HD(K)*FCT*DCOS(AZ5/RAD) CALL DEG(CORA,IA,MA,SA) WRITE(6,107)IA,MA,SA WRITE(6,108) WRITE(6,109)IS(1), XB,YB WRITE(6,110)X1(1),Y1(1) X(1)=XB Y(1)=YB DO 213 I=1,N X(I+1)=X(I)+HD(I)*FCT*DSIN(AZ(I)/RAD) Y(I+1)=Y(I)+HD(I)*FCT*DCOS(AZ(I)/RAD) WRITE(6,109)IS(I+1),X(I+1),Y(I+1) 213 WRITE(6,110)X1(I+1),Y1(I+1) AZ5=BG(XE-X(M),YE-Y(M)) CD=DSQRT((XE-X(M))**2+(YE-Y(M))**2) CALL DEG(AZ5,IA,MA,SA) WRITE(6,111)IA,MA,SA,CD GO TO 200 207 F=CORA/F F1=CORA/F1 SUM=0. DO 214 I=1,N SUM=SUM+1.+GC(I) 214 AZ(I)=AZ(I)+F*SUM CALL DEG(CORA,IA,MA,SA) F=F*3600. F1=F1*3600. WRITE(6,107)IA,MA,SA,SUM WRITE(6,112)F1,F GO TO 221 21 IS(N+1)=ISE CALL DISK(ISE,2,XE,YE,Z) CALL DISK(ISB,2,XB,YB,Z) WRITE(6,104)XB,YB,XE,YE GO TO (23,23,24),KN 23 DO 215 I=1,N READ(5,105)IS(I),A1,A2,A3,HD(I) WRITE(6,106)IS(I),A1,A2,A3,HD(I) 215 AZ(I)=A1+A2/60.+A3/3600. GO TO 221 24 DO 216 I=1,N READ(5,113)IS(I),K,A1,A2,A3,HD(I) WRITE(6,114)IS(I),K,A1,A2,A3,HD(I) AZ5=A1+A2/60.+A3/3600. GO TO(217,218,219,220),K 217 AZ(I)=AZ5 GO TO 216 218 AZ(I)=180.-AZ5 GO TO 216 219 AZ(I)=180.+AZ5 GO TO 216 220 AZ(I)=360.-AZ5 216 CONTINUE 221 X(1)=XB Y(1)=YB SD=0. DO 222 I=1,N SD=SD+HD(I)*FCT X(I+1)=X(I)+HD(I)*FCT*DSIN(AZ(I)/RAD) 222 Y(I+1)=Y(I)+HD(I)*FCT*DCOS(AZ(I)/RAD) DX=XE-X(N+1) DY=YE-Y(N+1) CD=DSQRT(DX*DX+DY*DY) AZC=BG(DX,DY) IPREC=SD/CD WRITE(6,115)IPREC CALL DEG(AZC,IA,MA,SA) WRITE(6,111)IA,MA,SA,CD IF(IPREC-IP)223,224,224 224 IF(KK-1)225,225,226 225 DX1=DX/SD DY1=DY/SD SD=0 DO 227 I=1,N SD=SD+HD(I)*FCT X(I+1)=X(I+1)+DX1*SD 227 Y(I+1)=Y(I+1)+DY1*SD GO TO 223 226 DX1=X(N+1)-XB DY1=Y(N+1)-YB FL=DSQRT(DX1*DX1+DY1*DY1) VL=(DY*DY1/FL+DX*DX1/FL)/FL VW=(DY1*DX/FL-DX1*DY/FL)/FL LP=1./VL LTP=1./VW AZ5=VW/4.85E-6 WRITE(6,116)LP WRITE(6,117)LTP WRITE(6,118)AZ5 DO 229 I=1,N DX1=X(I+1)-XB DY1=Y(I+1)-YB X(I+1)=X(I+1)+VL*DX1+VW*DY1 229 Y(I+1)=Y(I+1)+VL*DY1-VW*DX1 223 WRITE(6,108) WRITE(6,119) WRITE(6,109)ISB,XB,YB DO 230 I=1,N DX=X(I+1)-X(I) DY=Y(I+1)-Y(I) DIST=DSQRT(DX*DX+DY*DY) AZ5=BG(DX,DY) CALL DEG(AZ5,IA,MA,SA) FCT1=DIST/HD(I) DIST=DIST+0.005 WRITE(6,120)IA,MA,SA,DIST,FCT1 DX1=X(I+1)+0.005 DY1=Y(I+1)+0.005 230 WRITE(6,121)IS(I+1),DX1,DY1 IF(IPREC-IP)232,231,231 232 WRITE(6,122) GO TO 200 231 M=N-1 DO 233 I=1,M IF(KP)234,234,235 235 DX1=X(I+1)+0.005 DY1=Y(I+1)+0.005 WRITE(7,98)IS(I+1),DX1,DY1 234 CALL DISK(IS(I+1),1,X(I+1),Y(I+1),Z) 233 CONTINUE GO TO 200 2 READ(5,123)ISR,ISB,ISE,N,KK,KN,KP,FCT WRITE(6,124)ISR,ISB,ISE,N,KK,KN,KP,FCT IF(FCT)236,237,236 237 FCT=1. 236 GO TO (241,242,242),KN 241 CALL DISK(ISR,2,XBR,YBR,Z) CALL DISK(ISB,2,XB,YB,Z) WRITE(6,104)XBR,YBR,XB,YB IF(FCT-67.)238,238,239 239 DIST=DSQRT((XBR-XB)**2+(YBR-YB)**2) FCT=DIST/FCT 238 X(1)=XB Y(1)=YB AZL=BG(XB-XBR,YB-YBR) 271 RAZ1=AZL DO 245 I=1,N READ(5,105)IS(I),A1,A2,A3,HD(I) WRITE(6,106)IS(I),A1,A2,A3,HD(I) AZ5=RAZ1-180. IF(AZ5)246,247,247 246 AZ5=AZ5+360. 247 AZ(I)=AZ5+A1+A2/60.+A3/3600.-360. IF(AZ(I))248,249,249 248 AZ(I)=AZ(I)+360. 249 RAZ1=AZ(I) 245 CONTINUE GO TO 250 242 CALL DISK(ISB,2,XB,YB,Z) WRITE(6,104)XB,YB X(1)=XB Y(1)=YB GO TO(251,251,252),KN 251 DO 253 I=1,N READ(5,105)IS(I),A1,A2,A3,HD(I) WRITE(6,106)IS(I),A1,A2,A3,HD(I) 253 AZ(I)=A1+A2/60.+A3/3600. GO TO 250 252 DO 254 I=1,N READ(5,113)IS(I),K,A1,A2,A3,HD(I) WRITE(6,114)IS(I),K,A1,A2,A3,HD(I) AZ5=A1+A2/60.+A3/3600. GO TO(255,256,257,258),K 255 AZ(I)=AZ5 GO TO 254 256 AZ(I)=180.-AZ5 GO TO 254 257 AZ(I)=180.+AZ5 GO TO 254 258 AZ(I)=360.-AZ5 254 CONTINUE 250 IS(N+1)=ISE WRITE(6,108) WRITE(6,119) WRITE(6,109)IS(1),XB,YB DO 260 I=1,N DIST=HD(I)*FCT+0.005 X(I+1)=X(I)+HD(I)*FCT*DSIN(AZ(I)/RAD) Y(I+1)=Y(I)+HD(I)*FCT*DCOS(AZ(I)/RAD) XE=X(I+1)+0.005 YE=Y(I+1)+0.005 CALL DEG(AZ(I),IA,MA,SA) WRITE(6,120)IA,MA,SA,DIST,FCT WRITE(6,121)IS(I+1),XE,YE CALL DISK(IS(I+1),1,X(I+1),Y(I+1),Z) IF(KP)260,260,261 261 WRITE(7,98)IS(I+1),XE,YE 260 CONTINUE IF(KK-1)200,200,262 262 KK=KK-1 READ(5,164)N,ISE WRITE(6,160) WRITE(6,164)N,ISE GO TO(271,251,252),KN 4 READ(5,133)N,KK,(IS(I),I=1,N) WRITE(6,133)N,KK,(IS(I),I=1,N) DO 314 I=1,N CALL DISK(IS(I),2,X(I),Y(I),Z) 314 WRITE(6,121)IS(I),X(I),Y(I) K=1 K1=N K2=1 IF(KK-1)315,315,316 316 READ(5,133)(NT(I+1),I=1,KK) WRITE(6,133)(NT(I+1),I=1,KK) NT(1)=1 315 DX=X(K1)-X(K2) DY=Y(K1)-Y(K2) AZL=BG(DX,DY) DIST=DSQRT(DX*DX+DY*DY) CALL DEG(AZL,IA,MA,SA) WRITE(6,134)IS(K2),IS(K1),IA,MA,SA,DIST K3=K1-K2 DO 317 I=1,K3 DX=X(K2+I)-X(K2) DY=Y(K2+I)-Y(K2) DIST=DSQRT(DX*DX+DY*DY) AZ5=BG(DX,DY) AZR=AZ5-AZL IF(AZR)318,319,319 318 AZR=AZR+360. 319 XE=DIST*DSIN(AZR/RAD) YE=DIST*DCOS(AZR/RAD) IF(XE)320,321,321 320 XE=XE*(-1.) WRITE(6,136)IS(K2+I),XE,YE GO TO 317 321 WRITE(6,135)IS(K2+I),XE,YE 317 CONTINUE IF(KK-1)322,322,323 323 IF(KK-K)322,324,324 324 K2=NT(K) K1=NT(K+1) K=K+1 GO TO 315 322 GO TO 200 5 READ(5,133)N,KK,(IS(I),I=1,N) WRITE(6,133)N,KK,(IS(I),I=1,N) DO 325 I=1,N CALL DISK(IS(I),2,X(I),Y(I),Z) 325 WRITE(6,121)IS(I),X(I),Y(I) GO TO(326,327,328,329),KK 326 SEG3=0. K=N GO TO 330 327 F=1 GO TO 332 328 F= -1. 332 K= N-3 SEG3=SEG(X(N),Y(N),X(N-1),Y(N-1),X(N-2),Y(N-2))*F GO TO 330 329 K=N-5 SEG1=SEG(X(N),Y(N),X(N-3),Y(N-3),X(N-4),Y(N-4)) SEG2=SEG(X(N),Y(N),X(N-1),Y(N-1),X(N-2),Y(N-2)) SEG3=SEG1-SEG2 330 AREA=X(1)*(Y(K)-Y(2)) J=K-2 DO 331 I=1,J 331 AREA=AREA+X(I+1)*(Y(I)-Y(I+2)) AREA=DABS(AREA+X(K)*(Y(K-1)-Y(1)))/2.+SEG3 AREA1=AREA/43560. WRITE(6,137)AREA,AREA1 GO TO 200 8 READ(5,133)N,(IS(I),I=1,N) DO 333 I=1,N 333 CALL DISK(IS(I),2,X(I),Y(I),Z) WRITE(6,138) DO 334 I=1,N,2 DIST=DSQRT((X(I+1)-X(I))**2+(Y(I+1)-Y(I))**2) AZ5=BG(X(I+1)-X(I),Y(I+1)-Y(I)) CALL DEG(AZ5,IA,MA,SA) 334 WRITE(6,139)IS(I),X(I),Y(I),IS(I+1),X(I+1),Y(I+1),IA,MA,SA,DIST GO TO 200 9 READ(5,133)ISE,N,(IS(I),I=1,N) WRITE(6,133)ISE,N,(IS(I),I=1,N) CALL DISK(ISE,2,XE,YE,Z) WRITE(6,109)ISE,XE,YE DO 335 I=1,N CALL DISK(IS(I),2,X(I),Y(I),Z) 335 WRITE(6,121)IS(I),X(I),Y(I) WRITE(6,140) DO 336 I=1,N,2 DIST=DSQRT((X(I)-XE)**2+(Y(I)-YE)**2) AZ5=BG(X(I+1)-X(I),Y(I+1)-Y(I)) CD=DSQRT((X(I+1)-X(I))**2+(Y(I+1)-Y(I))**2) SEG1=CD/2. ARC=DARSIN(SEG1/DIST)*DIST*2. CALL DEG(AZ5,IA,MA,SA) 336 WRITE(6,141)IS(I),IS(I+1),ARC,IA,MA,SA,CD,DIST GO TO 200 11 DO 530 I=1,2 READ(5,152)NT(I),IS(I),A1,A2,A3,D1,D2,D3 WRITE(6,152)NT(I),IS(I),A1,A2,A3,D1,D2,D3 CALL DISK(IS(I),2,X(I),Y(I),Z) WRITE(6,121)IS(I),X(I),Y(I) AZ(I)=A1+A2/60.+A3/3600. 530 AZ(I+2)=D1+D2/60.+D3/3600. X1(1)=100000. Y1(1)=110000. X1(2)=100000. Y1(2)=100000. CALL COORD(X1(2),Y1(2),AZ(2),X1(1),Y1(1),AZ(1),XBR,YBR) IF((AZ(3)-180.))531,532,532 531 CALL COORD(X1(2),Y1(2),AZ(4),X1(1),Y1(1),AZ(3),XER,YER) GO TO 533 532 CALL COORD(X1(1),Y1(1),AZ(3),X1(2),Y1(2),AZ(4),XER,YER) 533 AZ5=BG(XBR-XER,YBR-YER) AZB=BG(X(2)-X(1),Y(2)-Y(1)) AZ5=AZB-AZ5 DO 537 I=1,4 HA(I)=AZ(I)+AZ5-360. IF(HA(I))534,537,537 534 HA(I)=HA(I)+360. IF(HA(I))535,537,537 535 HA(I)=HA(I)+360. 537 CONTINUE WRITE(6,108) DO 538 I=1,2 IF((AZ(I+2)-AZ(I))-180.)539,536,536 539 CALL COORD(X(1),Y(1),HA(I),X(2),Y(2),HA(I+2),X1(I),Y1(I)) GO TO 85 536 CALL COORD(X(2),Y(2),HA(I+2),X(1),Y(1),HA(I),X1(I),Y1(I)) 85 CALL DISK(NT(I),1,X1 (I),Y1(I),Z) 538 WRITE(6,109)NT(I),X1(I),Y1(I) GO TO 200 13 READ(5,158)ISB,ISR,N,KK,CD WRITE(6,158)ISB,ISR,N,KK,CD CALL DISK(ISB,2,XB,YB,Z) CALL DISK(ISR,2,XBR,YBR,Z) AZL=BG(XB-XBR,YB-YBR) R=DSQRT((XB-XBR)**2+(YB-YBR)**2) IF(KK-2)571,572,572 571 A1=1 GO TO 573 572 A1=(-1.) 573 WRITE(6,129)ISB,XB,YB,R WRITE(6,129)ISR,XBR,YBR DO 570 K=1,N READ(5,159)ISE,J,ARC,WR1,WL1,WR2,WL2 WRITE(6,165)ISE,J,ARC,WR1,WL1,WR2,WL2 165 FORMAT('0',2I6,F12.2,4F8.2) WRITE(6,128) X1(1)=R X1(2)=R+WR1 X1(3)=R+WL1 X1(4)=R+WR2 X1(5)=R+WL2 AZ5=(ARC-CD)/R*RAD*A1 AZR=AZL+AZ5-360. IF(AZR)575,577,577 575 AZR=AZR+360. IF(AZR)576,577,577 576 AZR=AZR+360. 577 DO 578 I=1,J XE=XBR+X1(I)*DSIN(AZR/RAD) YE=YBR+X1(I)*DCOS(AZR/RAD) ISR=ISE+I-1 CALL DISK(ISR,1,XE,YE,Z) 578 WRITE(6,129)ISR,XE,YE,X1(I) 570 CONTINUE GO TO 200 14 READ(5,162)ISR,ISB,ISE,N,K,FCT,A1,A2,A3,DIST WRITE(6,163)ISR,ISB,ISE,N,K,FCT,A1,A2,A3,DIST AZ5=A1+A2/60.+A3/3600. DIST=DIST*FCT GO TO (70,71),K 70 CALL DISK(ISR,2,XBR,YBR,Z) CALL DISK(ISB,2,XB,YB,Z) WRITE(6,121)ISR,XBR,YBR AZB=BG(XBR-XB,YBR-YB) AZ5=AZ5+AZB-360. IF(AZ5)72,73,73 72 AZ5=AZ5+360. GO TO 73 71 CALL DISK(ISB,2,XB,YB,Z) 73 WRITE(6,121)ISB,XB,YB CALL DEG(AZ5,IA,MA,SA) WRITE(6,108) WRITE(6,119) WRITE(6,109)ISB,XB,YB DO 74 I=1,N XB=XB+DIST*DSIN(AZ5/RAD) YB=YB+DIST*DCOS(AZ5/RAD) CALL DISK(ISE,1,XB,YB,Z) WRITE(6,120)IA,MA,SA,DIST,FCT WRITE(6,121)ISE,XB,YB 74 ISE=ISE+1 GO TO 200 END SUBROUTINE INTRCT IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE 108 FORMAT('0STATION X COORDINATE Y COORDINATE') 109 FORMAT('0',I7,2F14.2) 121 FORMAT(' ',I7,2F14.2) 125 FORMAT(7I6,4F6.2) 126 FORMAT('0',7I6,4F8.2) 127 FORMAT('0STA',I6, ' TO STA',I6, I8,I3,F5.1,F12.2) 128 FORMAT('0STATION X COORDINATE Y COORDINATE RADIUS') 129 FORMAT('0',I7,2F14.2,F10.2) 130 FORMAT('0STATION X COORDINATE Y COORDINATE RADIUS 1 RADIUS 2 1STATION X COORDINATE Y COORDINATE') 131 FORMAT('0',I7,' NO INTERSECTION') 132 FORMAT('0',I7,2F14.2,2F10.2,I9,2F14.2) 140 FORMAT('0STATION STATION ARC AZIMUTH DISTANCE RADIUS') 160 FORMAT('0') 161 FORMAT(' ') RAD=57.2957795 Z=0 3 READ(5,125)ISE,IS(1),IS(2),IS(3),IS(4),KK,N,WR1,WL1,WR2,WL2 WRITE(6,126)ISE,IS(1),IS(2),IS(3),IS(4),KK,N,WR1,WL1,WR2,WL2 WRITE(6,161) GO TO(280,281,282,283,284),KK 280 DO 285 I=1,4 CALL DISK(IS(I),2,X(I),Y(I),Z) 285 WRITE(6,121)IS(I),X(I),Y(I) AZ(1)=BG(X(2)-X(1),Y(2)-Y(1)) AZ(3)=BG(X(4)-X(3),Y(4)-Y(3)) CALL COORD(X(1),Y(1),AZ(1),X(3),Y(3),AZ(3),XE,YE) DO 286 I=1,3,2 HD(I)=DSQRT((X(I)-XE)**2+(Y(I)-YE)**2) CALL DEG(AZ(I),IA,MA,SA) 286 WRITE(6,127)IS(I),ISE,IA,MA,SA,HD(I) WRITE(6,109)ISE,XE,YE CALL DISK(ISE,1,XE,YE,Z) IF(N-1)200,200,287 200 RETURN 287 N=N-1 WRITE(6,160) READ(5,125)ISE,IS(1),IS(2),IS(3),IS(4) WRITE(6,126)ISE,IS(1),IS(2),IS(3),IS(4) GO TO 280 281 WRITE(6,161) DO 288 I=1,4 CALL DISK(IS(I),2,X(I),Y(I),Z) 288 WRITE(6,121)IS(I),X(I),Y(I) AZL=BG(X(2)-X(1),Y(2)-Y(1)) AZR=BG(X(4)-X(3),Y(4)-Y(3)) AZ5=AZL-270. IF(AZ5)289,290,290 289 AZ5=AZ5+360. 290 X1(1)=X(1)+WR1*DSIN(AZ5/RAD) Y1(1)=Y(1)+WR1*DCOS(AZ5/RAD) X1(2)=X(1) Y1(2)=Y(1) X1(3)=X(1)-WL1*DSIN(AZ5/RAD) Y1(3)=Y(1)-WL1*DCOS(AZ5/RAD) AZ5=AZR-270. IF(AZ5)291,292,292 291 AZ5=AZ5+360. 292 X(1)=X(3)+WR2*DSIN(AZ5/RAD) Y(1)=Y(3)+WR2*DCOS(AZ5/RAD) X(2)=X(3) Y(2)=Y(3) X(3)=X(3)-WL2*DSIN(AZ5/RAD) Y(3)=Y(3)-WL2*DCOS(AZ5/RAD) WRITE(6,108) DO 293 J=1,3 DO 294 I=1,3 CALL COORD(X1(J),Y1(J),AZL,X(I),Y(I),AZR,XE,YE) WRITE(6,109)ISE,XE,YE CALL DISK(ISE,1,XE,YE,Z) 294 ISE=ISE+1 293 CONTINUE RETURN 282 DO 295 I=1,2 CALL DISK(IS(I),2,X(I),Y(I),Z) 295 WRITE(6,121)IS(I),X(I),Y(I) CALL DISK(IS(3),2,XB,YB,HD(2)) WRITE(6,129)IS(3),XB,YB,HD(2) AZL=BG(X(2)-X(1),Y(2)-Y(1)) AZ5=AZL-270. IF(AZ5)296,297,297 296 AZ5=AZ5+360. 297 X1(1)=X(1)+WR1*DSIN(AZ5/RAD) Y1(1)=Y(1)+WR1*DCOS(AZ5/RAD) X1(2)=X(1) Y1(2)=Y(1) X1(3)=X(1)-WL1*DSIN(AZ5/RAD) Y1(3)=Y(1)-WL1*DCOS(AZ5/RAD) HD(1)=HD(2)+WR2 HD(3)=HD(2)+WL2 WRITE(6,128) DO 298 J=1,3 DO 299 I=1,3 CALL RSCT(X1(J),Y1(J),XB,YB,HD(I),AZL,XE,YE) WRITE(6,129)ISE,XE,YE,HD(I) CALL DISK(ISE,1,XE,YE,Z) 299 ISE=ISE+1 298 CONTINUE RETURN 283 CALL DISK(IS(1),2,XBR,YBR,X(2)) WRITE(6,129)IS(1),XBR,YBR,X(2) CALL DISK(IS(2),2,XB,YB,Y(2)) WRITE(6,129)IS(2),XB,YB,Y(2) X(1)=X(2)+WR1 X(3)=X(2)+WL1 Y(1)=Y(2)+WR2 Y(3)=Y(2)+WL2 DIST=DSQRT((XB-XBR)**2+(YB-YBR)**2) WRITE(6,130) AZ1=BG(XB-XBR,YB-YBR) DO 303 J=1,3 DO 302 I=1,3 ISB=ISE+9 IF(X(J)+Y(I)-DIST)304,305,306 304 WRITE(6,131)ISE GO TO 307 305 XE=XBR+X(J)*DSIN(AZ1/RAD) YE=YBR+X(J)*DCOS(AZ1/RAD) CALL DISK(ISE,1,XE,YE,Z) WRITE(6,132)ISE,XE,YE,X(J),Y(I) GO TO 307 306 S=(DIST+X(J)+Y(I))/2. AZ5=DATAN(DSQRT((S-X(J))*(S-DIST)/(S*(S-Y(I)))))*2.*RAD AZL=AZ1+AZ5-360. IF(AZL)309,310,310 309 AZL=AZL+360. 310 AZR=AZ1-AZ5 IF(AZR)311,312,312 311 AZR=AZR+360. 312 XE=XBR+X(J)*DSIN(AZL/RAD) YE=YBR+X(J)*DCOS(AZL/RAD) XER=XBR+X(J)*DSIN(AZR/RAD) YER=YBR+X(J)*DCOS(AZR/RAD) WRITE(6,132)ISE,XE,YE,X(J),Y(I),ISB,XER,YER CALL DISK(ISE,1,XE,YE,Z) CALL DISK(ISB,1,XER,YER,Z) 307 ISE=ISE+1 302 CONTINUE 303 CONTINUE RETURN 284 DO 308 I=1,2 CALL DISK(IS(I),2,X(I),Y(I),Z) 308 WRITE(6,121)IS(I),X(I),Y(I) AZL=BG(X(2)-X(1),Y(2)-Y(1)) CALL DISK(IS(3),2,XB,YB,HD(5)) WRITE(6,129)IS(3),XB,YB,HD(5) HD(1)=HD(5)+WR1 HD(2)=HD(5)+WL1 HD(3)=HD(5)+WR2 HD(4)=HD(5)+WL2 WRITE(6,128) DO 313 I=1,N CALL RSCT(X(1),Y(1),XB,YB,HD (I),AZL,XE,YE) WRITE(6,129)ISE,XE,YE,HD(I) CALL DISK(ISE,1,XE,YE,Z) 313 ISE=ISE+1 RETURN END SUBROUTINE CURV1 IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE 108 FORMAT('0STATION X COORDINATE Y COORDINATE') 121 FORMAT(' ',I7,2F14.2) 128 FORMAT('0STATION X COORDINATE Y COORDINATE RADIUS') 129 FORMAT('0',I7,2F14.2,F10.2) 133 FORMAT(11I6) 140 FORMAT('0STATION STATION ARC AZIMUTH DISTANCE RADIUS') 141 FORMAT('0',I7,I8,F9.2,I5,I3,F5.1,F10.2,F10.2) 142 FORMAT(2I6,2F6.2) 143 FORMAT(4I6,2F6.2) 144 FORMAT('0BC X',F12.2,' BC Y',F12.2,' EC X',F12.2,' EC Y',F12.2) 145 FORMAT(' PI X',F12.2,' PI Y',F12.2,' RP X',F12.2,' RP Y',F12.2) 146 FORMAT(' I ANGLE',I4,I3,F5.1,' TAN DIST',F9.2,' RADIUS',F9.2) 147 FORMAT(' ARC',F9.2,' LONG CHORD',I5,I3,F5.1,F9.2) 148 FORMAT(F12.2,2F6.2) 149 FORMAT(11F6.2) Z=0 RAD=57.2957795 6 READ(5,133)ISE,N,N1,KK,(IS(I),I=1,N) WRITE(6,133)ISE,N,N1,KK,(IS(I),I=1,N) DO 400 I=1,N CALL DISK(IS(I),2,X(I),Y(I),Z) 400 WRITE(6,121)IS(I),X(I),Y(I) GO TO (401,401,401,403,404,405),KK 401 K=(N-1) DO 406 I=1,K IF(N1-1)407,407,408 407 K1=I K2=I+1 GO TO 409 408 K1= N+1-I K2=N-I 409 X1(I)=(X(K1)+X(K2))/2. Y1(I)=(Y(K1)+Y(K2))/2. AZ(I)=BG(X(K2)-X(K1),Y(K2)-Y(K1))-270. IF(AZ(I))410,406,406 410 AZ(I)=AZ(I)+360. 406 CONTINUE K=K-1 L=1 WX=0 WY=0 SW=0 413 DO 411 I=1,K AZ5=DABS(AZ(J)-AZ(L))/RAD J=L+I CALL COORD(X1(L),Y1(L),AZ(L),X1(J),Y1(J),AZ(J),XE,YE) WT=1.E4/DSQRT((X1(L)-XE)**2+(Y1(L)-YE)**2+(X1(J)-XE)**2 1+(Y1(J)-YE)**2)*(DSIN(AZ5)**2) WX=WX+XE*WT WY=WY+YE*WT 411 SW=SW+WT L=L+1 K=K-1 IF(K)412,412,413 412 XE=WX/SW YE=WY/SW R=0 F=N DO 414 I=1,N DIST=DSQRT((X(I)-XE)**2+(Y(I)-YE)**2) WRITE(6,129)IS(I),X(I),Y(I),DIST 414 R=R+DIST R=R/F WRITE(6,129)ISE,XE,YE,R IF(KK-2)415,416,417 415 WRITE(6,128) WRITE(6,129)ISE,XE,YE,R CALL DISK(ISE,1,XE,YE,R) RETURN 416 READ(5,142)NT(1),NT(2),WR1,WL1 DO 418 I=1,2 CALL DISK(NT(I),2,X1(I),Y1(I),Z) 418 WRITE(6,121)NT(I),X1(I),Y1(I) AZ5=BG(X1(2)-X1(1),Y1(2)-Y1(1)) IF(N1-1)419,419,420 419 AZL=AZ5-90. F=1 IF(AZL)421,422,422 421 AZL=AZL+360. 422 CALL COORD(XE,YE,AZL,X1(1),Y1(1),AZ5,XB,YB) GO TO 423 420 F=(-1.) AZL=AZ5-270. IF(AZL)424,425,425 424 AZL=AZL+360. 425 CALL COORD(X1(1),Y1(1),AZ5,XE,YE,AZL,XB,YB) 423 R=DSQRT((XB-XE)**2+(YB-YE)**2) AZ(1)=AZL AZ(2)=BG(X(N)-XE,Y(N)-YE) 442 HD(1)=R HD(2)=R-WR1*F HD(3)=R+WL1*F CALL DISK(ISE,1,XE,YE,R) WRITE(6,128) WRITE(6,129)ISE,XE,YE,R WRITE(6,108) ISB=ISE K1=0 DO 426 J=1,2 DO 427 I=1,3 K=K1+I IS(K)=ISB+I X1(K)=XE+HD(I)*DSIN(AZ(J)/RAD) Y1(K)=YE+HD(I)*DCOS(AZ(J)/RAD) CALL DISK(IS(K),1,X1(K),Y1(K),Z) 427 WRITE(6,121)IS(K),X1(K),Y1(K) K1=K1+3 426 ISB=ISB+3 WRITE(6,140) DO 428 I=1,3 AZ5=BG(X1(I+3)-X1(I),Y1(I+3)-Y1(I)) CD=DSQRT((X1(I+3)-X1(I))**2+(Y1(I+3)-Y1(I))**2) SEG1=CD/2. ARC=DARSIN(SEG1/HD(I))*HD(I)*2. CALL DEG(AZ5,IA,MA,SA) 428 WRITE(6,141)IS(I),IS(I+3),ARC,IA,MA,SA,CD,HD(I) RETURN 417 READ(5,143)NT(1),NT(2),NT(3),NT(4),WR1,WL1 DO 429 I=1,4 CALL DISK(NT(I),2,X1(I),Y1(I),Z) 429 WRITE(6,121)NT(I),X1(I),Y1(I) 444 A2=BG(X1(4)-X1(3),Y1(4)-Y1(3)) AZ5=BG(X1(2)-X1(1),Y1(2)-Y1(1)) AZR=BG(X1(3)-X1(4),Y1(3)-Y1(4)) IF(N1-1)430,430,431 430 F=1 AZ(1)=AZ5-90. AZ(2)=A2-90. AZL=AZR AZR=AZ5 AI=A2-AZ5 CALL COORD(X1(4),Y1(4),AZL,X1(1),Y1(1),AZR,XPI,YPI) GO TO 432 431 F=(-1.) AI=AZ5-A2 AZ(1)=AZ5-270. AZ(2)=A2-270. CALL COORD(X1(1),Y1(1),AZ5,X1(4),Y1(4),AZR,XPI,YPI) 432 IF(AI)433,434,434 433 AI=AI+360. 434 A3=AI/(2.*RAD) TD=R*DTAN(A3) XB=XPI-TD*DSIN(AZ5/RAD) YB=YPI-TD*DCOS(AZ5/RAD) XER=XPI+TD*DSIN(A2/RAD) YER=YPI+TD*DCOS(A2/RAD) IF(AZ(1))435,436,436 435 AZ(1)=AZ(1)+360. 436 IF(AZ(2))437,438,438 437 AZ(2)=AZ(2)+360. 438 XE=XB-R*DSIN(AZ(1)/RAD) YE=YB-R*DCOS(AZ(1)/RAD) 441 ARC=R*A3*2. AZ5=BG(XER-XB,YER-YB) DIST=R*DSIN(A3)*2. CALL DEG(AI,IA,MA,SA) WRITE(6,144)XB,YB,XER,YER WRITE(6,145)XPI,YPI,XE,YE WRITE(6,146)IA,MA,SA,TD,R CALL DEG(AZ5,IA,MA,SA) WRITE(6,147)ARC,IA,MA,SA,DIST GO TO 442 403 READ(5,148)R,WR1,WL1 DO 443 I=1,4 X1(I)=X(I) 443 Y1(I)=Y(I) GO TO 444 405 READ(5,149)CR,E,WR1,WL1 AZL=BG(X(2)-X(1),Y(2)-Y(1)) AZR=BG(X(3)-X(2),Y(3)-Y(2)) IF(N1-1)445,445,446 445 AI=AZR-AZL F=1. GO TO 447 446 AI=AZL-AZR F=(-1.) 447 IF(AI)448,449,449 448 AI=AI+360. 449 AZ5=AZL-270. IF(AZ5)450,451,451 450 AZ5=AZL+360. 451 AZB=AZR-270. IF(AZB)452,453,453 452 AZB=AZB+360. 453 X1(1)=X(1)-CR*DSIN(AZ5/RAD)*F Y1(1)=Y(1)-CR*DCO S(AZ5/RAD)*F X1(2)=X1(1)+1000.*DSIN(AZL/RAD) Y1(2)=Y1(1)+1000.*DCOS(AZL/RAD) X1(4)=X(3)-CR*DSIN(AZB/RAD)*F Y1(4)=Y(3)-CR*DCOS(AZB/RAD)*F X1(3)=X1(4)-1000.*DSIN(AZR/RAD) Y1(3)=Y1(4)-1000.*DCOS(AZR/RAD) A3=AI/(RAD*2.) E=E+CR/DCOS(A3) R=E/DSIN(A3/2.)*DCOS(A3)/2./DSIN(A3/2.) GO TO 444 404 READ(5,149)WR1,WL1 DO 454 I=1,4 X1(I)=X(I) 454 Y1(I)=Y(I) AZL=BG(X(2)-X(1),Y(2)-Y(1)) AZR=BG(X(3)-X(4),Y(3)-Y(4)) AZ5=BG(X(4)-X(3),Y(4)-Y(3)) IF(N1-1)455,455,456 455 AI=AZ5-AZL CALL COORD(X(4),Y(4),AZR,X(1),Y(1),AZL,XPI,YPI) GO TO 457 456 AI=AZL-AZ5 CALL COORD(X(1),Y(1),AZL,X(4),Y(4),AZR,XPI,YPI) 457 IF(AI)458,459,459 458 AI=AI+360. 459 TD=DSQRT((XPI-X(2))**2+(YPI-Y(2))**2) R=TD/DTAN(AI/(2*RAD)) GO TO 444 END SUBROUTINE CURV2 IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE 121 FORMAT(' ',I7,2F14.2) 128 FORMAT('0STATION X COORDINATE Y COORDINATE RADIUS') 129 FORMAT('0',I7,2F14.2,F10.2) 133 FORMAT(11I6) 137 FORMAT('0AREA IS',F11.0,' SQ FT OR',F9.2,' ACRES') 138 FORMAT('0STATION X COORDINATE Y COORDINATE STATION X COORDINATE Y 1 COORDINATE AZIMUTH DISTANCE') 139 FORMAT(' ',I7,2F13.2,I9,2F13.2,I5,I3,F5.1,F10.2) 140 FORMAT('0STATION STATION ARC AZIMUTH DISTANCE RADIUS') 141 FORMAT('0',I7,I8,F9.2,I5,I3,F5.1,F10.2,F10.2) 151 FORMAT(6I6,4F6.2) RAD=57.2957795 Z=0 7 READ(5,151)ISE,N,N1,K,IB1,IE1,WR1,WL1 WRITE(6,152)ISE,N,N1,K,IB1,IE1,WR1,WL1 152 FORMAT(6I6,4F8.2) READ(5,133)(IS(I),I=1,N) SUM=0. DO 476 I=1,N CALL DISK(IS(I),2,X(I),Y(I),Z) 476 WRITE(6,121)IS(I),X(I),Y(I) M=N-1 DO 477 I=1,M AZ(I)=BG(X(I+1)-X(I),Y(I+1)-Y(I)) 477 HD(I)=DSQRT((X(I+1)-X(I))**2+(Y(I+1)-Y(I))**2) IF(N1-1)478,478,479 478 A1=3. A2=1. GO TO 480 479 A1=1. A2=(-1.) 480 BZ=AZ(1)-90.*A1 EAZ=BG(X(N-1)-X(N),Y(N-1)-Y(N)) 499 EZ=EAZ-90.*A1 IF (BZ)481,482,482 481 BZ=BZ+360. 482 IF(EZ)483,484,484 483 EZ=EZ+360. 484 IF(K-3)485,485,486 485 M=N-3 BAZ1=BZ M1=N/2 M1=M1*2 M1=M1-N IF(M1)487,488,488 487 C=(-1) GO TO 489 488 C=1. 489 DO 490 I=1,M IF(A2)491,492,492 491 ANG=AZ(I+1)-BAZ1 GO TO 493 492 ANG=BAZ1-AZ(I+1) 493 IF(ANG)494,495,495 494 ANG=ANG+360. 495 ANG1=(90.-ANG)*2.*A2 BAZ1=BAZ1+ANG1-360. IF(BAZ1)496,490,490 496 BAZ1=BAZ1+360. IF(BAZ1)497,490,490 497 BAZ1=BAZ1+360. 490 CONTINUE IF(A2)500,501,501 501 ANG2=AZ(N-2)-EZ GO TO 502 500 ANG2=EZ-AZ(N-2) 502 IF(ANG2)503,504,504 503 ANG2=ANG2+360. 504 ERR=ANG-ANG2 AZ1=BG(X(2)-X(3),Y(2)-Y(3)) IF(K-2)505,506,507 505 ER1=ERR/4. AZ1=AZ1+ER1*C*A2-360. AZ5=AZ(N-2)+ER1*A2-360. GO TO 508 506 ER1=ERR/2. AZ1=AZ1+ER1*C*A2-360. AZ5=AZ(N-2) GO TO 508 507 ER1=ERR/2. AZ5=AZ(N-2)+ER1*A2-360. 508 IF(AZ1)509,510,510 509 AZ1=AZ1+360. 510 IF(AZ5)511,512,512 511 AZ5=AZ5+360. 512 XB=X(2) YB=Y(2) YER=Y(N-1) XER=X(N-1) IF(A2)513,514,514 513 CALL COORD(X(1),Y(1),AZ(1),X(3),Y(3),AZ1,X(2),Y(2)) CALL COORD(X(N-2),Y(N-2),AZ5,X(N),Y(N),EAZ,X(N-1),Y(N-1)) GO TO 515 514 CALL COORD(X(3),Y(3),AZ1,X(1),Y(1),AZ(1),X(2),Y(2)) CALL COORD(X(N),Y(N),EAZ,X(N-2),Y(N-2),AZ5,X(N-1),Y(N-1)) 515 AZ(2)=BG(X(3)-X(2),Y(3)-Y(2)) AZ(N-2)=AZ5 HD(1)=DSQRT((X(2)-X(1))**2+(Y(2)-Y(1))**2) HD(2)=DSQRT((X(3)-X(2))**2+(Y(3)-Y(2))**2) HD(N-2)=DSQRT((X(N-1)-X(N-2))**2+(Y(N-1)-Y(N-2))**2) HD(N-1)=DSQRT((X(N)-X(N-1))**2+(Y(N)-Y(N-1))**2) IS(2)=IB1 IS(N-1)=IE1 CALL DISK(IB1,1,X(2),Y(2),Z) CALL DISK(IE1,1,X(N-1),Y(N-1),Z) GO TO 516 486 M=N-2 516 BAZ1=BZ DO 517 I=1,M IF(A2)518,519,519 518 ANG=AZ(I+1)-BAZ1 GO TO 520 519 ANG=BAZ1-AZ(I+1) 520 IF(ANG)521,522,522 521 ANG=ANG+360. 522 HD(161)=HD(I+1)/2./DCOS(ANG/RAD) HD(160)=HD(161)-WR1*A2 HD(162)=HD(161)+WL1*A2 NT(1)=ISE+1 NT(2)=IS(I+1) NT(3)=ISE+2 NT(4)=NT(1)+3 NT(5)=IS(I+2) NT(6)=NT(3)+3 ANG1=(90.-ANG)*2.*A2 ANG2=DABS(ANG1)/RAD XE=X(I+1)+HD(161)*DSIN(BAZ1/RAD) YE=Y(I+1)+HD(161)*DCOS(BAZ1/RAD) WRITE(6,128) CALL DISK(ISE,1,XE,YE,HD(161)) WRITE(6,129)ISE,XE,YE,HD(161) DO 580 J=1,3 XR=XE-HD(J+159)*DSIN(BAZ1/RAD) YR=YE-HD(J+159)*DCOS(BAZ1/RAD) CALL DISK(NT(J),1,XR,YR,Z) 580 WRITE(6,129)NT(J),XR,YR,HD(J+159) WRITE(6,140) CALL DEG(AZ(I+1),IA,MA,SA) DO 581 J=1,3 ARC=HD(J+159)*ANG2 DIST=HD(I+1)/HD(161)*HD(J+159) 581 WRITE(6,141)NT(J),NT(J+3),ARC,IA,MA,SA,DIST,HD(J+159) AREA=(WR1+WL1)*HD(161)*ANG2 AREA1=AREA/43560. WRITE(6,137)AREA,AREA1 SUM=SUM+AREA BAZ1=BAZ1+ANG1-360. IF(BAZ1)523,524,524 523 BAZ1=BAZ1+360. IF(BAZ1)525,524,524 525 BAZ1=BAZ1+360. 524 ISE=ISE+3 517 CONTINUE WRITE(6,128) DO 582 I=1,3 XR=XE-HD(I+159)*DSIN(BAZ1/RAD) YR=YE-HD(I+159)*DCOS(BAZ1/RAD) CALL DISK(NT(I+3),1,XR,YR,Z) 582 WRITE(6,129)NT(I+3),XR,YR,HD(I+159) AREA1=SUM/43560. WRITE(6,137)SUM,AREA1 WRITE(6,138) CALL DEG(AZ(1),IA,MA,SA) WRITE(6,139)IS(1),X(1),Y(1),IS(2),X(2),Y(2),IA,MA,SA,HD(1) CALL DEG(AZ(N-1),IA,MA,SA) WRITE(6,139)IS(N-1),X(N-1),Y(N-1),IS(N),X(N),Y(N),IA,MA,SA,HD(N-1) RETURN END SUBROUTINE RESEX IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE 102 FORMAT(4I6,I4,I6,3I3,F9.6,F5.0) 103 FORMAT('0',9I6,F12.6,F6.0) 108 FORMAT('0STATION X COORDINATE Y COORDINATE') 109 FORMAT('0',I7,2F14.2) 127 FORMAT('0STA',I6, ' TO STA',I6,' AZIMUTH'I5,I3,F5.1,' DISTANCE', 1F10.2) 150 FORMAT(' ',3I7,2F14.2,F12.6) 154 FORMAT(I6,2F6.0,F6.1) 155 FORMAT(' ',I7,2F13.2,F7.0,F4.0,F5.1) Z=0 RAD=57.2957795 10 READ(5,102)ISE,N WRITE(6,103)ISE,N DO 460 I=1,N READ(5,154)IS(I),A1,A2,A3 CALL DISK(IS(I),2,X(I),Y(I),Z) HA(I)=A1+A2/60.+A3/3600. 460 WRITE(6,155)IS(I),X(I),Y(I),A1,A2,A3 M=N-1 DO 462 I=1,M HD(I)=DSQRT((X(I+1)-X(I))**2+(Y(I+1)-Y(I))**2)/2. 462 AZ(I)=BG(X(I+1)-X(I),Y(I+1)-Y(I)) SW=0. WX=0 WY=0 M=N-2 DO 463 I=1,M AZ5=HA(I+1)-HA(I) AZB=HA(I+2)-HA(I+1) D1=HD(I)/DSIN(AZ5/RAD) D2=HD(I+1)/DSIN(AZB/RAD) AZL=AZ(I)+AZ5-270. IF(AZL)464,465,465 464 AZL=AZL+360. 465 AZR=AZ(I+1)-AZB-270. IF(AZR)466,467,467 466 AZR=AZR+360. IF(AZR)468,467,467 468 AZR=AZR+360. 467 XB=X(I+1)+D1*DSIN(AZL/RAD) YB=Y(I+1)+D1*DCOS(AZL/RAD) XBR=X(I+1)+D2*DSIN(AZR/RAD) YBR=Y(I+1)+D2*DCOS(AZR/RAD) A3=BG(XBR-XB,YBR-YB) A2=A3-180. IF(A2)469,470,470 469 A2=A2+360. 470 AI=A2-AZL IF(AI)471,472,472 471 AI=AI+360. 472 AZL=A3+AI-360. IF(AZL)473,474,474 473 AZL=AZL+360. 474 XE=XB+D1*DSIN(AZL/RAD) YE=YB+D1*DCOS(AZL/RAD) IF(N-3)700,700,701 701 WT =1.E5/DSQRT((X(I)-XE)**2+(Y(I)-YE)**2+(X(I+1)-XE)**2+ 1(Y(I+1)-YE)**2+(X(I+2)-XE)**2+(Y(I+2)-YE)**2)*DSIN(AZ5/RAD)**2 2*DSIN(AZB/RAD)**2 WX=WX+XE*WT WY=WY+YE*WT SW=SW+WT 463 WRITE(6,150)IS(I),IS(I+1),IS(I+2),XE,YE,WT XE=WX/SW YE=WY/SW 700 CALL DISK(ISE,1,XE,YE,Z) WRITE(6,108) WRITE(6,109)ISE,XE,YE DO 475 I=1,N AZL=BG(X(I)-XE,Y(I)-YE) D1=DSQRT((X(I)-XE)**2+(Y(I)-YE)**2) CALL DEG(AZL,IA,MA,SA) 475 WRITE(6,127)ISE,IS(I),IA,MA,SA,D1 RETURN END SUBROUTINE INTR2 IMPLICIT REAL*8(A-H,O-Z) COMMON X(200),Y(200),X1(200),Y1(200),HA(200),AZ(200),HD(200), 1HDR(6),XE,YE,Z,IS(200),NT(20),ISE 108 FORMAT('0STATION X COORDINATE Y COORDINATE') 109 FORMAT('0',I7,2F14.2) 133 FORMAT(11I6) 152 FORMAT(2I6,2(F6.0,F6.0,F6.1)) 153 FORMAT(' ',I6,2F13.2,I8,2F13.2,2(F7.0,F4.0,F5.1)) 154 FORMAT(I6,2F6.0,F6.1) 155 FORMAT(' ',I7,2F13.2,F7.0,F4.0,F5.1) 156 FORMAT(' ',I6,I9,' UNADJ X',F13.2,' UNADJ Y',F13.2,' WT',F9.5, 1' AZ CORRN',F7.1) 157 FORMAT('0',I7,' ADJ X',F13.2,' ADJ Y',F13.2,' S.E.',F7.3) Z=0 RAD=57.2957795 12 READ(5,133)ISE,N,KK IF(KK-2)540,540,542 540 DO 541 I=1,N READ(5,152)NT(I),IS(I),A1,A2,A3,D1,D2,D3 HA(I)=A1+A2/60.+A3/3600. AZ(I)=D1+D2/60.+D3/3600. CALL DISK(IS(I),2,X(I),Y(I),Z) CALL DISK(NT(I),2,X1(I),Y1(I),Z) 541 WRITE(6,153)NT(I),X1(I),Y1(I),IS(I),X(I),Y(I),A1,A2,A3,D1,D2,D3 GO TO 543 542 DO 544 I=1,N READ(5,154)IS(I),A1,A2,A3 CALL DISK(IS(I),2,X(I),Y(I),Z) AZ(I)=A1+A2/60.+A3/3600. 544 WRITE(6,155)IS(I),X(I),Y(I),A1,A2,A3 543 IF(-K-2)545,546,547 546 DO 548 I=1,N AZ(I)=BG(X1(I)-X(I),Y1(I)-Y(I))+HA(I)-360. IF(AZ(I))549,548,548 549 AZ(I)=AZ(I)+360. 548 CONTINUE GO TO 547 545 DO 550 I=1,N 550 HD(I)=BG(X1(I)-X(I),Y1(I)-Y(I)) 547 M=N-1 L=1 WX=0. WY=0. SW=0. K=1 AZ5=0. 551 DO 552 I=1,M J=L+I IF(KK-2)553,554,554 553 AZL=HD(L)+HA(L)-360. IF(AZL)555,556,556 555 AZL=AZL+360. 556 AZR=AZL+(AZ(J)-AZ(L))-360. IF(AZR)557,558,558 557 AZR=AZR+360. 558 AZB=AZR-HA(J) IF(AZB)559,560,560 559 AZB=AZB+360. 560 AZ5=(HD(J)-AZB)/3. AZL=AZL+AZ5 AZR=AZR+AZ5*2. GO TO 561 554 AZL=AZ(L) AZR=AZ(J) 561 CALL COORD(X(L),Y(L),AZL,X(J),Y(J),AZR,XE,YE) IF(N-2)562,562,563 563 X1(K)=XE Y1(K)=YE X1(100+K)=1.E4/DSQRT((X(L)-XE)**2+(Y(L)-YE)**2+(X(J)-XE)**2+ 1(Y(J)-YE)**2)*DSIN(DABS(AZR-AZL)/RAD)**2 AZ1=AZ5*3600. WX=WX+X1(K)*X1(100+K) WY=WY+Y1(K)*X1(100+K) SW=SW+X1(100+K) WRITE(6,156)IS(L),IS(J),X1(K),Y1(K),X1(K+100),AZ1 552 K=K+1 L=L+1 M=M-1 IF(M)564,564,551 564 K=K-1 XE=WX/SW YE=WY/SW SV=0 DO 565 I=1,K 565 SV=SV+((X1(I)-XE)**2+(Y1(I)-YE)**2)*X1(I+100) FK=K-1 XB=DSQRT(SV/(SW*FK)) WRITE(6,157)ISE,XE,YE,XB GO TO 566 562 WRITE(6,108) WRITE(6,109)ISE,XE,YE 566 CALL DISK(ISE,1,XE,YE,Z) DO 570 I=1,N AZ1=BG(XE-X(I),YE-Y(I)) DIST=DSQRT((XE-X(I))**2+(YE-Y(I))**2) CALL DEG(AZ1,IA,MA,SA) 570 WRITE(6,159)IS(I),ISE,IA,MA,SA,DIST 159 FORMAT('0STA',I7,' TO',I7,' AZIMUTH',I5,I3,F5.1,' DISTANCE',F10 1.2) RETURN END FUNCTION SEG(A,B,C,D,E,F) IMPLICIT REAL*8(A-H,O-Z) G=DSQRT((A-C)**2+(B-D)**2) H=DSQRT((C-E)**2+(D-F)**2)/2. AR=H*DSQRT(G*G-H*H) AR1=DARSIN(H/G)*G*G SEG=AR1-AR RETURN END SUBROUTINE COORD(XL,YL,AZL,XR,YR,AZR,XP,YP) IMPLICIT REAL*8(A-H,O-Z) RAD=57.2957795 DX12=XL-XR DY12=YL-YR COS1P=DCOS (AZR/RAD) COS2P=DCOS(AZL/RAD) IF(DABS(COS1P)-3.E-8)16,17,17 16 YP=YR TAN2P=DSIN(AZL/RAD)/COS2P GO TO 20 17 IF(DABS(COS2P)-3.E-8)18,19,19 18 YP=YL TAN1P=DSIN(AZR/RAD)/COS1P GO TO 21 19 TAN1P=DSIN(AZR/RAD)/COS1P TAN2P=DSIN(AZL/RAD)/COS2P DY1P=(TAN2P*DY12-DX12)/(TAN2P-TAN1P) DY2P=(TAN1P*DY12-DX12)/(TAN2P-TAN1P) DX1P=DY1P*TAN1P DX2P=DY2P*TAN2P YP=(YR+DY1P+YL+DY2P)/2. XP=(XR+DX1P+DX2P+XL)/2. RETURN 20 XP=XL-DY12*TAN2P RETURN 21 XP=XR+DY12*TAN1P RETURN END FUNCTION BG(DX,DY) DOUBLE PRECISION DX,DY,RAD,BG RAD=57.2957795 IF(DABS(DY)-0.0005)3,6,6 3 IF(DX)4,5,5 4 BG=270.0 RETURN 5 BG=90.0 RETURN 6 BG=DATAN(DX/DY)*RAD IF(DY)7,8,8 7 BG=BG+180. RETURN 8 IF(DX)9,10,10 9 BG=BG+360. 10 RETURN END SUBROUTINE RSCT(XB1,YB1,XP,YP,R,AZ1,RX,RY) IMPLICIT REAL*8(A-H,O-Z) RAD=57.2957795 AZ2=BG(XP-XB1,YP-YB1) DIST=DSQRT((XP-XB1)**2+(YP-YB1)**2) ANG=AZ1-AZ2 IF(ANG)1,2,3 1 ANG=ANG+360. 3 IF(ANG-180.)4,2,5 5 ANG=360.-ANG 4 BANG=DARSIN(DSIN(ANG/RAD)/R*DIST)*RAD IF(R-DIST)10,12,11 10 BANG=180.-BANG 11 DIST=R/DSIN(ANG/RAD)*DSIN((ANG+BANG)/RAD) GO TO 13 12 DIST=R*DSIN((90.-ANG)/RAD)*2. 13 RX=XB1+DSIN(AZ1/RAD)*DIST RY=YB1+DCOS(AZ1/RAD)*DIST RETURN 2 RX=XP-R*DSIN(AZ2/RAD) RY=YP-R*DCOS(AZ2/RAD) RETURN END SUBROUTINE DISK(I,J,X,Y,Z) IMPLICIT REAL*8(X,Y,Z) DEFINE FILE 3(2500,25,U,JB) DIMENSION X1(4),Y1(4),Z1(4) IF (I.GT. 9999 .OR. I .LE. O ) GO TO 5 I1=I/4 I2=I-I1*4+1 I1=I1+1 READ(3'I1)(X1(K),Y1(K),Z1(K),K=1,4) GO TO (1,2),J 1 X1(I2)=X Y1(I2)=Y Z1(I2)=Z WRITE(3'I1)(X1(K),Y1(K),Z1(K),K=1,4) RETURN 2 X=X1(I2) Y=Y1(I2) Z=Z1(I2) RETURN 5 WRITE(6,6) 6 FORMAT('->>> STATION NUMBER OUT OF RANGE 1 TO 9999 <<<'/ 1 'UNTIL DECEMBER 31, 1968 THIS WILL BE RERUN AT NO CHARGE WITH OUR 2 APOLOGIES FOR YOUR INCONVENIENCE' ) CALL EXIT END SUBROUTINE DEG(ANG,ID,IM,SS) IMPLICIT REAL*8(A-H,O-Z) ID=ANG AID=ID FID=(ANG-AID)*60. IM=FID FIS=IM SS=(FID-FIS)*60. RETURN END