CTITLESAGSVR -- INTERPRETATION OF SURVEY NOTES BY GM3D 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR J. MENDEKE 00000200 CA DESIGNER J. MENDEKE 00000300 CA LANGUAGE FORTRAN 00000400 CA SYSTEM IBM AND CRAY 00000501 CA WRITTEN 06/26/78 00000600 C REVISED 03/05/80 JGM - PRINTED OUT ALL STATION INFO 00000700 C REVISED 01/29/81 RFE - ADDED ZENITH ANGLE SECONDS TO 00000800 C INPUT 'SVR' FORMAT. 00000900 C REVISED 02/24/81 SAS - ADDED CHECK FOR NEAREST TENTH UNIT 00001000 C COLUMN - BLANK IMPLIES ZERO. 00001100 C REVISED 05-06-81 SAS - ADDED TWO PASS STATION NAME SEARCH 00001200 C FOR NON STANDARD SURVEY LINE. 00001300 C REVISED 02-22-82 NTS - CORRECTIONS IN READING CO-ORDINATES. 00001400 C CORRECTIONS IN THE PRINTING OF 00001600 C COMPUTED SURVEY DATA FROM "SVR" 00001700 C CARDS.DATA PRINTED ONLY IF SVR 00001800 C CARD PRESENT. 00001900 C REVISED 04-22-82 NTS - MODIFIED FOR GM3D 'XYA' CARD 00002000 C FORMAT THAT WILL ADJUST X-Y 00002100 C COORDINATES FROM 'SVR' CARDS 00002200 C REVISED 03-07-85 RDK - DUAL VSFORTRAN/CFT CODE. 00002300 C CORRECT CHARACTER COMPARES AT 610. 00002400 C REVISED 03-20-89 TJT - SINGLE SOURCE CODE FOR IBM AND CRAY. 00002501 C REVISED 11-13-89 RDK - FOR CRAY CFT77 COMPATIBILITY. 00002602 C 00002800 CA 00002900 CA CALL SAGSVR (KPNA, KPRNO, KPBUGF, KPWARN, IPR, ERR, MNRVI, 00003000 CA * BLNKC, CARD, ANSTNA, AZSTN, WKX, WKY, WKELE, NOCSVR, 00003100 CA * MNRV, MNDX, NRVS, RVLSNO, RVX, RVY, RELEV) 00003200 CA 00003300 CA 00003400 CA INPUT KPNA = PROCESS NAME A4 00003500 CA INPUT KPRNO = PROCESS NO. I4 00003600 CA INPUT KPBUGF = DEBUG FLAG I4 00003700 CA INPUT KPWARN = WARNING FLAG I4 00003800 CA INPUT IPR = PRINTER UNIT NO. I4 00003900 CA I / O ERR = ERR IDICATOR I4 00004000 CA INPUT MNRVI = MINIMUM RECEIVER BASE INDEX I4 00004100 CA INPUT BLNKC = BLANK CARD IMAGE A4 00004200 CA INPUT CARD = CARD IMAGE WORK AREA ARRAY A4 00004300 CA INPUT ANSTNA = ALPH-NUMERIC STATION WORK AREA ARRAY R8 00004400 CA INPUT AZSTN = STATION AZIMUTH WORK AREA ARRAY R4 00004500 CA INPUT WKX = X-CORD. WORK AREA ARRAY R8 00004600 CA INPUT WKY = Y-CORD. WORK AREA ARRAY R8 00004700 CA INPUT WKELE = ELEVATION WORK AREA ARRAY R4 00004800 CA OUTPUT NOCSVR = NUMBER OF 'SVR' CARDS READ I4 00004900 CA OUTPUT MNRV = MINIMUM RECEIVER I4 00005000 CA OUTPUT MNDX = MINIMUM RECEIVER INDEX I4 00005100 CA OUTPUT NRVS = NUMBER OF RECEIVERS I4 00005200 CA OUTPUT RVLSNO = RECEIVER LINE STATION NO. R4 00005300 CA OUTPUT RVX = RECEIVER STATION X-CORD. R8 00005400 CA OUTPUT RVY = RECEIVER STATION Y-CORD. R8 00005500 CA OUTPUT RELEV = RECEIVER STATION ELEVATIONS I4 00005600 CA 00005700 CA 00005900 CA SAGSVR IS CALLED BY PREPARATION ROUTINE 'GM3D' TO READ 00006000 CA AND INTERPRET SURVEY NOTES. THIS SURVEY INFORMATION 00006100 CA IS USED TO COMPUTE X-Y CORDINATES AND ELEVATIONS. 00006200 CC EJECT 00006300 SUBROUTINE SAGSVR (KPNA, KPRNO, KPBUGF, KPWARN, IPR, ERR, MNRVI, 00006400 * BLNKC, CARD, ANSTNA, AZSTN, WKX, WKY, WKELE, NOCSVR, 00006500 * MNRV, MNDX, NRVS, RVLSNO, RVX, RVY, RELEV) 00006600 C 00006800 IMPLICIT INTEGER (A-Z) 00006900 C EXTERNAL S1ATP 00007001 C 00007100 C REAL ARRAYS IN PARAMETER LIST. 00007200 C 00007300 REAL RVLSNO(1) 00007400 CHARACTER*16 ANSTNA(1) 00007500 REAL AZSTN (1) 00007600 DOUBLE PRECISION RVX (1) 00007700 DOUBLE PRECISION RVY (1) 00007800 DOUBLE PRECISION WKX (1) 00007900 DOUBLE PRECISION WKY (1) 00008000 REAL WKELE (1) 00008100 C 00008200 C********** ADD CODE FOR XYA ********** 00008300 C 00008400 DOUBLE PRECISION XFACT 00008500 DOUBLE PRECISION YFACT 00008600 DOUBLE PRECISION DIST 00008700 DOUBLE PRECISION CDIST 00008800 DOUBLE PRECISION CUDIST 00008900 DOUBLE PRECISION XLAST 00009000 DOUBLE PRECISION YLAST 00009100 DOUBLE PRECISION XCURR 00009200 DOUBLE PRECISION YCURR 00009300 DOUBLE PRECISION X1ADJ 00009400 DOUBLE PRECISION Y1ADJ 00009500 DOUBLE PRECISION O8X 00009600 DOUBLE PRECISION O8Y 00009700 DOUBLE PRECISION XSQ 00009800 DOUBLE PRECISION YSQ 00009900 C 00010100 INTEGER XYAFLG 00010200 INTEGER ONECRD 00010300 INTEGER NOCXYA 00010400 INTEGER ERRFLG 00010500 INTEGER FOC 00010600 C 00010900 C********** END CODE FOR XYA ********** 00011000 C 00011100 C INTEGER ARRAYS IN PARAMETER LIST. 00011200 C 00011300 CHARACTER*80 BLNKC 00011400 CHARACTER*80 CARD 00011500 INTEGER RELEV (1) 00011600 C 00011800 C REAL VARIABLES AND CONSTANTS 00011900 C 00012000 CHARACTER*16 STNAME 00012100 CHARACTER*4 XYA 00012200 CHARACTER*4 SVR 00012300 CHARACTER*4 O 00012400 CHARACTER*4 S 00012500 CHARACTER*4 T 00012600 C 00012700 REAL TWOPI 00012800 REAL FLOATN 00012900 REAL RODRDG 00013000 REAL OELEV 00013100 REAL OAZ 00013200 DOUBLE PRECISION OXC 00013300 DOUBLE PRECISION OYC 00013400 REAL OBAZ 00013500 REAL OBZNA 00013600 REAL HORZD 00013700 REAL SLOPED 00013800 REAL DPR 00013900 REAL HI 00014000 REAL XDPT 00014100 REAL YLAT 00014200 REAL RODC 00014300 REAL RFACK 00014400 C 00014500 C INITIALIZATION AREA 00014600 C 00014700 DATA TWOPI /6.283185307/ 00014800 DATA XYAFLG /0/ 00014900 DATA ONECRD /0/ 00015000 DATA NOCXYA /0/ 00015100 DATA ERRFLG /1/ 00015200 DATA FOC /0/ 00015300 DATA XYA /'XYA ' / 00015500 DATA SVR /'SVR ' / 00015600 DATA O /'O ' / 00015700 DATA S /'S ' / 00015800 DATA T /'T ' / 00015900 C 00016000 C INITIALIZATION AREA 00016100 C 00016200 IF (1.EQ.2) CALL S1ATP 00016301 C 00016401 DA1 = 1 00016500 LERR = ERR 00016600 INDX = 1 00016700 RVINC = 1 00016800 DPR = 360. / TWOPI 00016900 RFACK = 48.58 00017000 C 00017100 COUT CALL S1MVCH (BLNKC, 1, STNAME, 11, 6) 00017200 STNAME(11:16) = BLNKC(1:6) 00017300 C 00017400 C GET FIRST OCCUPIED STATION CARD 00017500 C 00017600 10 CALL FORC (KPNA, KPRNO, DA1, CARD, *1000) 00017700 C 00017800 C********** ADD CODE FOR XYA ********** 00017900 C 00018000 COUT IF( S1CPCH (CARD, 8, 'XYA', 1, 3) .EQ. 0) GO TO 600 00018100 IF( CARD(8:10) .EQ. XYA(1:3) ) GO TO 600 00018201 C 00018300 C 00018400 C********** END CODE FOR XYA ********** 00018500 C 00018600 COUT IF (S1CPCH (CARD, 8, 'SVR', 1, 3) .NE. 0) GO TO 10 00018700 COUT IF (S1CPCH (CARD,16, 'O', 1, 1) .NE. 0) GO TO 10 00018800 IF ( CARD(8:10) .NE. SVR(1:3) ) GO TO 10 00018901 IF ( CARD(16:16) .NE. O(1:1) ) GO TO 10 00019001 C 00019100 C FIRST OCCUPIED STATION CARD REQUIRES: 00019200 C AZIMUTH, X-CORD., Y-CORD, 00019300 C ROD READING, AND ELEVATION. 00019400 C 00019500 COUT IF (S1CPCH (CARD, 28, BLNKC, 1, 7) .EQ. 0 .OR. 00019600 COUT * S1CPCH (CARD, 50, BLNKC, 1, 8) .EQ. 0 .OR. 00019700 COUT * S1CPCH (CARD, 58, BLNKC, 1, 8) .EQ. 0 .OR. 00019800 COUT * S1CPCH (CARD, 66, BLNKC, 1, 3) .EQ. 0 .OR. 00019900 COUT * S1CPCH (CARD, 75, BLNKC, 1, 6) .EQ. 0 ) GO TO 2000 00020001 C 00020100 20 IF ( CARD(28:34) .EQ. BLNKC(1:7) .OR. 00020201 * CARD(50:57) .EQ. BLNKC(1:8) .OR. 00020301 * CARD(58:65) .EQ. BLNKC(1:8) .OR. 00020401 * CARD(66:68) .EQ. BLNKC(1:3) .OR. 00020501 * CARD(75:80) .EQ. BLNKC(1:6) ) GO TO 2000 00020601 C 00020700 C INTERPRET OCCUPIED STATION CARD 00020800 C 00020900 C 00021000 COUT CALL S1MVCH (CARD, 17, ANSTNA(INDX), 1, 10) 00021100 COUT CALL S1MVCH (BLNKC, 1, ANSTNA(INDX), 11, 6) 00021200 ANSTNA(INDX)( 1:10) = CARD(17:26) 00021300 ANSTNA(INDX)(11:16) =BLNKC( 1: 6) 00021400 C 00021500 COUT AZNS = BLNKC(1) 00021600 COUT CALL S1MVCH (CARD, 27, AZNS, 1, 1) 00021700 AZD = S1CVBN (CARD, 28, 3) 00021800 AZM = S1CVBN (CARD, 31, 2) 00021900 AZS = S1CVBN (CARD, 33, 2) 00022000 COUT AZEW = BLNKC(1) 00022100 COUT CALL S1MVCH (CARD, 35, AZEW, 1, 1) 00022200 C 00022300 C SET AZIMUTH TO TOTAL DEGREES 00022400 C 00022500 OAZ = AZD 00022600 OAZ = OAZ + AZM/60. + AZS/3600. 00022700 AZSTN(INDX) = OAZ 00022800 C SET X AND Y COORDINATES 00022900 WKX(INDX) = S1CVBN (CARD, 50, 8) 00023000 COUT IF (S1CPCH(CARD,57,BLNKC,1,1) .NE. 0) WKX(INDX) = WKX(INDX) / 10. 00023100 IF (CARD(57:57) .NE. BLNKC(1:1) ) WKX(INDX) = WKX(INDX) / 10. 00023201 WKY(INDX) = S1CVBN (CARD, 58, 8) 00023300 COUT IF (S1CPCH(CARD,65,BLNKC,1,1) .NE. 0) WKY(INDX) = WKY(INDX) / 10. 00023400 IF (CARD(65:65) .NE. BLNKC(1:1) ) WKY(INDX) = WKY(INDX) / 10. 00023501 OXC = WKX(INDX) 00023600 OYC = WKY(INDX) 00023700 C 00023800 C****** ADD CODE FOR XYA ************** 00023900 C 00024000 C IF NO ADJUSTMENT THEN SKIP THIS SECTION 00024100 C 00024200 IF ( ( ONECRD .NE. 1) .AND. (XYAFLG .NE. 1)) GO TO 70 00024300 C 00024400 C IF ONLY ONE XYA CARD READ ADJUST XY HERE 00024500 IF ( ONECRD .NE. 1 ) GO TO 60 00024600 C 00024700 C SAVE THE CURRENT X,Y BEFORE ADJUSTMENT 00024800 C 00024900 XCURR = OXC 00025000 YCURR = OYC 00025100 WKX(INDX) = WKX(INDX) + X1ADJ 00025200 WKY(INDX) = WKY(INDX) + Y1ADJ 00025300 OXC = OXC + X1ADJ 00025400 OYC = OYC + Y1ADJ 00025500 GO TO 65 00025600 C 00025700 60 CONTINUE 00025800 IF ( XYAFLG .NE. 1 ) GO TO 65 00025900 CNT = CNT - 1 00026000 C 00026100 C SAVE THE CURRENT X-Y BEFORE THE ADJUSTMENT 00026201 C 00026300 XCURR = OXC 00026400 YCURR = OYC 00026500 C 00026600 C COMPUTE THE DISTANCE AND UPDATE CUDIST 00026700 C 00026800 IF ( XLAST .EQ. 0.0 .AND. YLAST .EQ. 0.0 ) GO TO 62 00026900 C 00027000 XSQ = XCURR-XLAST 00027100 XSQ = XSQ*XSQ 00027200 YSQ = YCURR-YLAST 00027400 YSQ = YSQ*YSQ 00027500 DIST = DSQRT ( XSQ + YSQ ) 00027700 CUDIST = CUDIST + DIST 00028000 C 00028300 62 CONTINUE 00028400 OXC = OXC + X1ADJ + CUDIST*XFACT 00028500 OYC = OYC + Y1ADJ + CUDIST*YFACT 00028600 XLAST = XCURR 00028700 YLAST = YCURR 00028800 C WRITE NEW X-Y IN THE WORK ARRAY 00028900 WKX(INDX) = OXC 00029000 WKY(INDX) = OYC 00029100 C 00029200 65 CONTINUE 00029300 C 00029400 C UPDATE THE FLAG FOR ONLY ONE XYA CARD HERE 00029500 ONECRD = 0 00029600 C 00029700 C IF THE VERY FIRST OCC. ST IS ADJUSTED ONLY,THEN RESET OXC,OYC 00029800 C 00029900 IF ( FOC .EQ. 0 ) OXC = XCURR 00030000 IF ( FOC .EQ. 0 ) OYC = YCURR 00030100 C 00030200 C RESET OXC AND OYC TO OCC. ST. BEFORE ADJUSTMENT,IF THIS WAS AN 00030400 C OCC. ST. OTHER THAN THE VERY FIRST ONE. 00030500 C 00030600 COUT IF((XYAFLG .NE. 1).OR.(S1CPCH(CARD,16,'O',1,1) .NE. 0))GO TO 70 00030701 IF((XYAFLG .NE. 1).OR.(CARD(16:16).NE. O(1:1) ))GO TO 70 00030901 OXC = XCURR 00031100 OYC = YCURR 00031200 C 00031400 70 CONTINUE 00031500 FOC = 1 00031600 C 00031700 C****** END CODE FOR XYA ************** 00031800 C ROD READING FROM FOOT OF INSTRUMENT 00031900 RODRDG = S1CVBN (CARD, 66, 3) 00032000 COUT IF (S1CPCH(CARD,68,BLNKC,1,1) .NE. 0) RODRDG = RODRDG / 10. 00032100 IF (CARD(68:68) .NE. BLNKC(1:1) ) RODRDG = RODRDG / 10. 00032201 C ELEVATION AT INSTRUMENT 00032300 OELEV = S1CVBN (CARD, 75, 6) 00032400 COUT IF (S1CPCH(CARD,80,BLNKC,1,1) .NE. 0) OELEV = OELEV / 10. 00032500 IF (CARD(80:80) .NE. BLNKC(1:1) ) OELEV = OELEV / 10. 00032601 WKELE(INDX) = OELEV 00032700 C COMPUTE HEIGHT OF INSTRUMENT 00032800 HI = OELEV + RODRDG 00032900 C DEFAULT OBSERVED AZIMUTH TO OCCUPIED AZIMUTH 00033000 OBAZ = OAZ 00033100 C INCREMENT STORAGE INDEX 00033200 INDX = INDX + 1 00033300 C 00033400 C SHOOT IN THE OBSERVED STATIONS 00033500 C 00033600 100 CALL FORC (KPNA, KPRNO, DA1, CARD, *1000) 00033700 C 00033800 C********** ADD CODE FOR XYA ********** 00033900 C 00034000 COUT IF (S1CPCH (CARD, 8, 'XYA', 1, 3) .EQ. 0) GO TO 600 00034100 IF (CARD(8:10) .EQ. XYA(1:3) ) GO TO 600 00034201 C 00034300 C********** END CODE FOR XYA ********** 00034400 C 00034500 COUT IF (S1CPCH (CARD, 8, 'SVR', 1, 3) .NE. 0) GO TO 1000 00034601 COUT IF (S1CPCH (CARD, 16, 'O', 1, 1) .EQ. 0) GO TO 200 00034701 COUT IF (S1CPCH (CARD, 16, 'S' , 1, 1) .EQ. 0) GO TO 500 00034801 COUT IF (S1CPCH (CARD, 16, 'T' , 1, 1) .EQ. 0) GO TO 500 00034901 COUT IF (S1CPCH (CARD, 16, BLNKC , 1, 1) .EQ. 0) GO TO 500 00035001 C 00035100 IF (CARD( 8:10) .NE. SVR(1:3) ) GO TO 1000 00035201 IF (CARD(16:16) .EQ. O(1:1) ) GO TO 200 00035301 IF (CARD(16:16) .EQ. S(1:1) ) GO TO 500 00035401 IF (CARD(16:16) .EQ. T(1:1) ) GO TO 500 00035501 IF (CARD(16:16) .EQ. BLNKC(1:1) ) GO TO 500 00035601 C 00035700 GO TO 100 00035801 C 00035900 200 CONTINUE 00036000 C 00036100 C NEW OCCUPIED STATION ENCOUNTERED 00036200 C 00036300 COUT CALL S1MVCH (CARD, 17, STNAME, 1, 10) 00036400 STNAME(1:10) = CARD(17:26) 00036500 C 00036600 C CHECK FOR THIS STATION ALREADY PROCESSED 00036700 INDXM1 = INDX -1 00036800 DO 210 00036901 * I = 1, INDXM1 00037000 N = INDXM1 - I + 1 00037100 IF (ANSTNA(N)(1:16) .EQ. STNAME(1:16)) GO TO 250 00037201 210 CONTINUE 00037300 C STATION NOT FOUND- MUST BE A NEW INITIAL STATION 00037400 GO TO 20 00037500 C INTERPRET OCCUPIED STATION CARD 00037600 C 00037700 250 CONTINUE 00037800 C 00037900 OAZ = AZSTN(N) 00038000 C CONVERT TO BACK-AZIMUTH 00038100 IF (AZSTN(N) .GE. 180.) OAZ = OAZ - 180. 00038200 IF (AZSTN(N) .LT. 180.) OAZ = OAZ + 180. 00038300 C 00038400 OXC = WKX(N) 00038500 OYC = WKY(N) 00038600 C****** ADD CODE FOR XYA ************** 00038700 C 00038800 C RESET OXC AND OYC TO OCC. ST. BEFORE ADJUSTMENT 00038900 C 00039000 COUT IF((XYAFLG .NE. 1).OR.(S1CPCH(CARD,16,'O',1,1) .NE. 0))GO TO 255 00039101 IF((XYAFLG .NE. 1).OR.(CARD(16:16) .NE. O(1:1) ))GO TO 255 00039201 OXC = XCURR 00039400 OYC = YCURR 00039500 C 00039900 255 CONTINUE 00040000 C****** END CODE FOR XYA ************** 00040100 OELEV = WKELE(N) 00040200 COUT IF (S1CPCH (CARD, 28, BLNKC, 1, 7) .EQ. 0) GO TO 260 00040301 IF (CARD(28:34) .EQ. BLNKC(1:7) ) GO TO 260 00040401 C 00040500 COUT AZNS = BLNKC(1) 00040600 COUT CALL S1MVCH (CARD, 27, AZNS, 1, 1) 00040700 AZD = S1CVBN (CARD, 28, 3) 00040800 AZM = S1CVBN (CARD, 31, 2) 00040900 AZS = S1CVBN (CARD, 33, 2) 00041000 COUT AZEW = BLNKC(1) 00041100 COUT CALL S1MVCH (CARD, 35, AZEW, 1, 1) 00041200 C 00041300 C SET AZIMUTH TO TOTAL DEGREES 00041400 C 00041500 OAZ = AZD 00041600 OAZ = OAZ + AZM/60. + AZS/3600. 00041700 C ROD READING FROM FOOT OF INSTRUMENT 00041800 C60 IF (S1CPCH (CARD, 66, BLNKC, 1, 3) .EQ. 0) GO TO 2010 00041901 260 IF (CARD(66:68) .EQ. BLNKC(1:3) ) GO TO 2010 00042001 RODRDG = S1CVBN (CARD, 66, 3) 00042100 COUT IF (S1CPCH (CARD,68,BLNKC,1,1) .NE. 0) RODRDG = RODRDG / 10. 00042200 IF (CARD(68:68) .NE. BLNKC(1:1) ) RODRDG = RODRDG / 10. 00042301 C ELEVATION AT INSTRUMENT 00042400 COUT IF (S1CPCH (CARD, 75, BLNKC, 1, 6) .EQ. 0) GO TO 270 00042501 IF (CARD(75:80) .EQ. BLNKC(1:6) ) GO TO 270 00042601 OELEV = S1CVBN (CARD, 75, 6) 00042700 COUT IF (S1CPCH(CARD,80,BLNKC,1,1) .NE. 0) OELEV = OELEV / 10. 00042800 IF (CARD(80:80) .NE. BLNKC(1:1) ) OELEV = OELEV / 10. 00042901 C COMPUTE HEIGHT OF INSTRUMENT 00043000 270 HI = OELEV + RODRDG 00043100 C 00043200 GO TO 100 00043301 C 00043400 C COMPUTATIONS FOR OBSERVED STATIONS 00043500 C 00043600 500 CONTINUE 00043700 C SAVE STATION NAME 00043800 COUT CALL S1MVCH (CARD, 17, ANSTNA(INDX), 1, 10) 00043900 COUT CALL S1MVCH (BLNKC, 1, ANSTNA(INDX),11, 6) 00044000 ANSTNA(INDX)( 1:10) = CARD(17:26) 00044100 ANSTNA(INDX)(11:16) =BLNKC( 1: 6) 00044200 C GET FIELD ANGLE 00044400 COUT IF (S1CPCH (CARD, 28, BLNKC, 1, 7) .EQ. 0) GO TO 520 00044501 IF ( CARD(28:34).EQ.BLNKC(1:7) ) GO TO 520 00044601 COUT FANS = BLNKC(1) 00044700 COUT CALL S1MVCH (CARD, 27, FANS, 1, 1) 00044800 FAD = S1CVBN(CARD, 28, 3) 00044900 FAM = S1CVBN(CARD, 31, 2) 00045000 FAS = S1CVBN(CARD, 33, 2) 00045100 COUT FAEW = BLNKC(1) 00045200 COUT CALL S1MVCH (CARD, 27, FAEW, 1, 1) 00045300 C FIND STATION AZIMUTH 00045400 OBAZ = FAD 00045500 OBAZ = OBAZ + FAM/60. + FAS/3600. + OAZ - 360. 00045600 IF (OBAZ .LT. 0.) OBAZ = OBAZ + 360. 00045700 IF (OBAZ .GT. 360.) OBAZ = OBAZ - 360. 00045800 C 00045900 520 AZSTN (INDX) = OBAZ 00046000 C GET ZENITH ANGLE 00046100 ZNAD = S1CVBN(CARD, 36, 4) 00046200 ZNAM = S1CVBN(CARD, 40,2) 00046300 ZNAS = S1CVBN(CARD, 42,2) 00046400 OBZNA = ZNAD 00046500 OBZNA = OBZNA + ZNAM/60. + ZNAS/3600. 00046600 C COMPUTE X AND Y CO-ORDINATES 00046700 SLOPED = S1CVBN(CARD, 44, 6) 00046800 COUT IF (S1CPCH(CARD,49,BLNKC,1,1) .NE. 0) SLOPED = SLOPED / 10. 00046900 IF (CARD(49:49).NE.BLNKC(1:1) ) SLOPED = SLOPED / 10. 00047000 HORZD = SLOPED * SIN(OBZNA/DPR) 00047100 XDPT = SIN(OBAZ/DPR) * HORZD 00047300 YLAT = COS(OBAZ/DPR) * HORZD 00047400 WKX(INDX) = OXC + XDPT 00047600 WKY(INDX) = OYC + YLAT 00047700 C****** ADD CODE FOR XYA ************** 00047800 C 00047900 C CHECK FOR ADJUSTMENT OF ONE CARD HERE 00048000 C 00048200 C IF ONLY ONE XYA CARD READ ADJUST XY HERE 00048300 IF ( ONECRD .EQ. 1 ) WKX(INDX) =WKX(INDX) + X1ADJ 00048400 IF ( ONECRD .EQ. 1 ) WKY(INDX) =WKY(INDX) + Y1ADJ 00048500 C 00048800 IF ( ONECRD .EQ. 1 ) GO TO 550 00048900 C 00049100 C IF NO ADJ. IS TO MADE THEN SKIP THE ADJUSTMENT ROUTINE 00049200 C 00049300 IF ( XYAFLG .NE. 1 ) GO TO 550 00049400 C 00049500 C RESET THE COUNTER 00049700 C 00049801 CNT = CNT - 1 00049900 C 00050100 C SAVE THE CURRENT X-Y BEFORE THE ADJUSTMENT 00050201 C 00050300 XCURR = WKX(INDX) 00050400 YCURR = WKY(INDX) 00050500 C 00050700 C THIS WILL WORK ONLY IF THE LAST OBSERVED SURVEY 00050800 C STATION NOW BECOMES AN OCCUPIED SURVEY STATION. 00050900 C **************** 00051401 C COMPUTE THE DISTANCE AND UPDATE CUDIST 00051501 C 00051600 IF ( XLAST .EQ. 0.0 .AND. YLAST .EQ. 0.0 ) GO TO 540 00051700 C 00051800 XSQ = XCURR-XLAST 00051900 XSQ = XSQ*XSQ 00052000 YSQ = YCURR-YLAST 00052200 YSQ = YSQ*YSQ 00052300 DIST = DSQRT ( XSQ + YSQ ) 00052500 CUDIST = CUDIST + DIST 00052800 C 00053100 540 CONTINUE 00053200 C 00053300 WKX(INDX) = WKX(INDX) + X1ADJ + CUDIST*XFACT 00053400 WKY(INDX) = WKY(INDX) + Y1ADJ + CUDIST*YFACT 00053500 C 00054000 C RESET THE XYAFLG WHEN CDIST AND CUDIST BECOME EQUAL 00054100 C 00054200 IF ( CUDIST .EQ. CDIST ) XYAFLG = 0 00054300 IF ( CNT .EQ. 0 ) XYAFLG = 0 00054400 XLAST = XCURR 00054600 YLAST = YCURR 00054700 550 CONTINUE 00054800 C 00054900 C UPDATE THE FLAG FOR ONLY ONE XYA CARD HERE 00055000 ONECRD = 0 00055100 C 00055400 C****** END CODE FOR XYA ************** 00055500 C COMPUTE ELEVATION 00055600 COUT IF (S1CPCH(CARD, 66, BLNKC, 1, 3) .EQ. 0) GO TO 580 00055701 IF (CARD(66:68) .EQ. BLNKC(1:3) ) GO TO 580 00055801 RODRDG = S1CVBN (CARD, 66, 3) 00055900 COUT IF (S1CPCH(CARD,68,BLNKC,1,1) .NE. 0) RODRDG = RODRDG / 10. 00056000 IF (CARD(68:68) .NE. BLNKC(1:1) ) RODRDG = RODRDG / 10. 00056101 C 00056200 580 FLOATN = SLOPED/1000. 00056300 RODC = RODRDG - (FLOATN * FLOATN) / RFACK 00056400 WKELE(INDX) = HI - RODC + SLOPED * COS(OBZNA/DPR) 00056500 INDX = INDX + 1 00056700 C 00056800 GO TO 100 00056901 C 00057000 C********** ADD CODE FOR XYA ********** 00057200 C 00057300 600 CONTINUE 00057400 C A XYA CARD IS READ WHEN WE GET HERE. 00057500 C SAVE X,Y OF THE CURRENT OCCUPIED STATION IF ANY OCC. STATION 00057600 C HAS BEEN PROCESSED BEFORE... 00057700 IF ( FOC .EQ. 0 ) GO TO 610 00057800 O8X = OXC 00057900 O8Y = OYC 00058000 610 CONTINUE 00058100 C 00058300 C READ AND STORE THE ADJUSTMENT FROM THE FIRST XYA CARD 00058400 C 00058500 X1ADJ = S1CVBN(CARD,11,10)/10.0 00058600 COUT IF (S1CPCH(CARD,20,BLNK,1,1) .EQ. 0) X1ADJ = X1ADJ*10.0 00058700 IF (CARD(20:20) .EQ. BLNKC(1:1) ) X1ADJ = X1ADJ*10.0 00058801 Y1ADJ = S1CVBN(CARD,21,10)/10.0 00058900 COUT IF (S1CPCH(CARD,30,BLNK,1,1) .EQ. 0) Y1ADJ = Y1ADJ*10.0 00059000 IF (CARD(30:30) .EQ. BLNKC(1:1) ) Y1ADJ = Y1ADJ*10.0 00059101 ERRFLG = 1 00059200 DAC = DA1 00059300 C 00059500 C CALL THE SUBROUTINE SAGXYA HERE 00059601 C 00059700 CALL SAGXYA(KPNA,KPRNO,IPR,DAC,NOCXYA,CDIST,CUDIST,CARD,CNT, 00059900 * FOC,XYAFLG,O8X,O8Y,OAZ,OBAZ,XFACT,YFACT,ONECRD, 00060000 * ERRFLG) 00060100 C 00060200 C GO BACK TO READ AS USUAL 00060300 XLAST = 0.0 00060400 YLAST = 0.0 00060500 DA1 = DAC 00060600 C 00060700 IF ( ERRFLG .EQ. 0 ) GO TO 1200 00060801 C 00060900 C IF NO OCC. STATION HAS BEEN READ BEFORE THEN GO TO FIRST READ 00061000 C OR ELSE GO TO SECOND READ 00061100 C 00061200 IF (FOC .EQ. 0 ) GO TO 10 00061300 C 00061400 C RESET THE X,Y OF THE OCCUPIED STATION BEFORE THE ADJUSTMENT 00061500 C 00061600 OXC = O8X 00061700 OYC = O8Y 00061800 C 00061900 C GO BACK TO READ AS USUAL 00062000 C 00062100 GO TO 100 00062200 C 00062500 C********** END CODE FOR XYA ********** 00062600 C 00062700 C RETURN SURVEY INFO FOR SPECIFIED INPUT STATIONS 00062800 C 00062900 1000 CONTINUE 00063000 C 00063100 IF (LERR .NE. ERR) GO TO 1050 00063201 K = 1 00063300 INDXM1 = INDX - 1 00063400 DA1 = 1 00063500 C 00063600 1010 CALL FORC (KPNA, KPRNO, DA1, CARD, *1050) 00063700 COUT IF (S1CPCH (CARD, 8, 'SVR', 1, 3) .NE. 0) GO TO 1010 00063801 COUT IF (S1CPCH (CARD, 16, 'O', 1, 1) .NE. 0 .AND. 00063900 COUT * S1CPCH (CARD, 16, BLNKC, 1, 1) .NE. 0) GO TO 1010 00064001 IF (CARD( 8:10) .NE. SVR(1:3) ) GO TO 1010 00064101 IF (CARD(16:16) .NE. O(1:1) .AND. 00064201 * CARD(16:16) .NE. BLNKC(1:1) ) GO TO 1010 00064301 C 00064400 COUT IF (S1CPCH (CARD, 11, BLNKC, 1, 5) .EQ. 0) GO TO 1010 00064501 IF (CARD(11:15) .EQ. BLNKC(1:5) ) GO TO 1010 00064601 C 00064700 IPASS = 1 00064800 NOCSVR = NOCSVR + 1 00064900 SRVNO = S1CVBN (CARD, 11, 5) 00065000 NDX = SRVNO - MNRV + MNRVI 00065100 IF (NDX .LT. MNDX) MNDX = NDX 00065200 IF (NDX .GT. NRVS) NRVS = NDX 00065300 C 00065400 COUT CALL S1MVCH (CARD, 17, STNAME, 1, 10) 00065500 STNAME(1:10) = CARD(17:26) 00065600 C FIND THIS STATION'S COMPUTED INFO 00065700 1015 DO 1020 00065801 * I = K, INDXM1 00065900 IF (STNAME(1:16) .EQ. ANSTNA(I)(1:16)) GO TO 1030 00066001 1020 CONTINUE 00066100 C 00066200 IF (IPASS .EQ. 2) GO TO 1025 00066301 IPASS = 2 00066400 K = 1 00066500 GO TO 1015 00066601 C 00066700 1025 LERR = LERR + 1 00066800 WRITE (IPR, 9120) CARD 00066900 GO TO 1010 00067001 C 00067100 1030 K = I 00067200 RVX (NDX) = WKX (I) 00067300 RVY (NDX) = WKY (I) 00067400 RELEV(NDX) = WKELE(I) 00067500 RVLSNO(NDX) = SRVNO 00067600 C 00067700 GO TO 1010 00067801 C 00067900 1050 ERR = LERR 00068000 C 00068200 C PRINT OF COMPUTED SURVEY INFO. 00068300 C CHECK IF ANY SVR CARDS WERE PRESENT. 00068400 C 00068500 IF (NOCSVR .EQ. 0 ) GO TO 1200 00068701 C 00068800 WRITE (IPR, 9130) 00068900 C 00069000 INDXM1 = INDX - 1 00069100 DO 1110 00069201 * I = 1, INDXM1 00069300 WRITE (IPR, 9140) 00069500 * ANSTNA(I), AZSTN(I), WKX(I), WKY(I), WKELE(I) 00069600 1110 CONTINUE 00069700 C 00069800 1200 RETURN 00069901 C 00070000 2000 WRITE (IPR, 9100) CARD 00070100 LERR = LERR + 1 00070200 GO TO 10 00070301 C 00070400 2010 WRITE (IPR, 9110) CARD 00070500 LERR = LERR + 1 00070600 GO TO 10 00070701 C 00070800 C **** FORMATS **** 00070901 C 00071000 9100 FORMAT (' *** INITIAL OCCUPIED STATION REQUIRES:',/, 00071100 * ' *** AZIMUTH, X-CORD., Y-CORD.,', 00071200 * ' ROD READING, AND ELEVATION',/, 1X, A80 ) 00071300 C 00071400 9110 FORMAT (' *** OCCUPIED STATION REQUIRES A ROD READING ',/, 00071500 * 1X, A80 ) 00071600 C 00071700 9120 FORMAT (' *** UNABLE TO FIND COMPUTED SURVEY DATA ',/,1X, A80) 00071800 C 00071900 9130 FORMAT ('1 COMPUTED SURVEY DATA FROM "SVR" CARDS ',//, 00072000 *' STATION NAME AZIMUTH X-COORD. Y-COORD.', 00072100 *' ELEVATION') 00072200 C 00072300 9140 FORMAT (4X, A16, 4F12.1) 00072400 C 00072500 END 00073000