CTITLESAGXYA -- X,Y ADJUSTMENT 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR NARENDRA SHETH 00000200 CA DESIGNER NARENDRA SHETH 00000300 CA LANGUAGE FORTRAN 00000400 CA SYSTEM IBM AND CRAY 00000501 CA WRITTEN 04-15-80 00000600 C REVISED 06-08-82 NTS. ADD SOME MORE CODE THAT WILL ALLOW 00000701 C 2 ADJACENT XYA CARDS. 00000801 C REVISED 03-01-85 RDK. REVISED FOR DUAL VSFORT AND CFT. 00000900 C REVISED 11-22-85 ESN. REVISED FOR NEW CRAY LOADLIB. 00001000 C REVISED 03-20-89 TJT. SINGLE SOURCE CODE FOR IBM AND CRAY. 00001101 C REVISED 11-13-89 RDK. FOR CRAY CFT77 COKMPATIBILITY. 00001202 CA 00001300 CA 00001400 CA SAGXYA IS CALLED BY SPSRVY IF THERE IS A XYA INPUT DATA 00001500 CA CARD IN THE 'GM3D' PROCESS. 00001600 CA IF THERE IS ONLY ONE XYA CARD THEN EITHER 'SVR' OR THE 'XYE' 00001700 CA CARD IMMEDIATELY FOLLOWING IT WILL HAVE ITS X,Y ADJUSTED 00001800 CA ACCORDING TO THE ADJUSTMENTS GIVEN ON THE 'XYA' CARD. 00001900 CA IF THERE ARE 2 XYA CARDS THEN ALL INTERMEDIATE STATIONS 00002000 CA BETWEEN THESE XYA CARDS WILL HAVE THEIR X,Y ADJUSTED 00002100 CA IF THERE ARE THREE OR MORE XYA CARDS THEN THE FIRST AND SECOND00002200 CA CARD WILL BE TREATED AS A PAIR, THE SECOND AND THE THIRD CARD 00002300 CA WILL BE TREATED AS PAIR AND SO ON.... 00002400 CA THIS PROGRAM REQUIRES THAT IF AN OCCUPIED STATION, OTHER THAN 00002500 CA THE FIRST ONE, HAS ITS X,Y TO BE ADJUSTED, THEN IT MUST BE 00002600 CA IMMEDIATELY PRECEDED BY AN OBSERVED STATION SUCH THAT BOTH THE 00002700 CA STATIONS HAVE THE SAME NAME. 00002800 CA 00002900 CA CALL SAGXYA( KPNA,KPRNO,IPR,DAC,NOCXYA,CDIST, 00003900 CA CUDIST,CARD,CNT,FOC,XYAFLG,O8X,O8Y, 00004000 CA OAZ,OBAZ,XFACT,YFACT,ONECRD,ERRFLG) 00004100 CA 00004201 C 00004400 SUBROUTINE SAGXYA(KPNA,KPRNO,IPR,DAC,NOCXYA,CDIST, 00004500 * CUDIST,CARD,CNT,FOC,XYAFLG,O8X,O8Y, 00004600 * OAZ,OBAZ,XFACT,YFACT,ONECRD,ERRFLG) 00004700 C 00005000 IMPLICIT INTEGER (A-Z) 00005100 C EXTERNAL S1ATP 00005201 C 00005500 C CHARACTER ARRAYS--LOCAL 00005600 C 00005700 CHARACTER*12 BLANK 00005800 CHARACTER*80 CARD 00005900 CHARACTER*8 GM3D 00006000 CHARACTER*4 LTR1 00006100 CHARACTER*10 STATON 00006200 CHARACTER*4 SVR 00006300 CHARACTER*4 XYE 00006400 CHARACTER*4 XYA 00006500 C 00006900 C REAL VARIABLES--LOCAL 00007000 C 00007100 REAL DPR 00007200 REAL ELEV 00007300 REAL FLOATN 00007400 REAL HI 00007500 REAL HORZD 00007600 REAL OAZ 00007700 REAL OBAZ 00007800 REAL OBZNA 00007900 REAL OELEV 00008000 REAL RODRDG 00008100 REAL SLOPED 00008200 C 00008300 C EXTENDED PRECISION VARIABLES--LOCAL 00008400 C 00008500 DOUBLE PRECISION OB8X 00008600 DOUBLE PRECISION OB8Y 00008700 DOUBLE PRECISION O8X 00008800 DOUBLE PRECISION O8Y 00008900 DOUBLE PRECISION REAL8 00009000 DOUBLE PRECISION XSQ 00009100 DOUBLE PRECISION YSQ 00009200 DOUBLE PRECISION DIST 00009300 DOUBLE PRECISION X1ADJ 00009400 DOUBLE PRECISION X2ADJ 00009500 DOUBLE PRECISION Y1ADJ 00009600 DOUBLE PRECISION Y2ADJ 00009700 DOUBLE PRECISION XNEW 00009800 DOUBLE PRECISION XOLD 00009900 DOUBLE PRECISION YNEW 00010000 DOUBLE PRECISION YOLD 00010100 DOUBLE PRECISION XFACT 00010200 DOUBLE PRECISION YFACT 00010300 DOUBLE PRECISION CDIST 00010400 DOUBLE PRECISION CUDIST 00010500 DOUBLE PRECISION XLAST 00010600 DOUBLE PRECISION YLAST 00010700 DOUBLE PRECISION XCURR 00010800 DOUBLE PRECISION YCURR 00010900 DOUBLE PRECISION XOCC 00011000 DOUBLE PRECISION YOCC 00011100 DOUBLE PRECISION XOBS 00011200 DOUBLE PRECISION YOBS 00011300 DOUBLE PRECISION OCCAZ 00011400 DOUBLE PRECISION TEMP1 00011500 DOUBLE PRECISION TEMP2 00011600 DOUBLE PRECISION TEMP3 00011700 C 00011800 C INTEGER VARIABLES--LOCAL 00011900 C 00012000 INTEGER ERRFLG 00012100 C 00012200 C INTIALIZE VARIABLES 00012301 C 00012400 DATA BLANK /' '/ 00012500 COUT DATA BLNK /' '/ 00012601 DATA DPR /57.29577951/ 00012700 DATA GM3D /'GM3D ' / 00012800 DATA LTR1 /'ANOR'/ 00012900 DATA SVR /'SVR '/ 00013000 DATA XYE /'XYE '/ 00013100 DATA XYA /'XYA '/ 00013200 C 00013400 C 00013700 IF (1.EQ.2) CALL S1ATP 00013801 C 00013901 5 CONTINUE 00014000 FOCC = FOC 00014100 C 00014200 C READ THE AJUSTMENTS FROM THIS CARD AS THE FIRST ADJUSTMENTS. 00014300 C IF NO X-Y ADJUSTMENT GIVEN ,WRITE AN ERROE MESSAGE 00014400 C 00014501 COUT IF (S1CPCH (CARD, 11, BLANK, 1,10) .EQ. 0) GO TO 370 00014600 COUT IF (S1CPCH (CARD, 21, BLANK, 1,10) .EQ. 0) GO TO 370 00014700 IF ( CARD(11:20) .EQ. BLANK(1:10) ) GO TO 370 00014800 IF ( CARD(21:30) .EQ. BLANK(1:10) ) GO TO 370 00014900 C 00015000 C SAVE DISK ADDRESS OF THE FIRST XYA CARD READ AND INITIALIZE 00015100 C ALL THE VARIABLES. 00015200 C 00015300 DAPR = DAC 00015400 NOCXYA = NOCXYA + 1 00015500 CDIST = 0.0 00015600 X1ADJ = S1CVBN (CARD,11 ,10) / 10.0 00015700 COUT IF (S1CPCH (CARD, 20,BLANK, 1, 1) .EQ. 0) X1ADJ = X1ADJ*10.0 00015800 IF ( CARD(20:20).EQ.BLANK(1:1) ) X1ADJ = X1ADJ*10.0 00015900 C 00016000 Y1ADJ = S1CVBN (CARD,21 ,10) / 10.0 00016100 COUT IF (S1CPCH (CARD, 30,BLANK, 1, 1) .EQ. 0) Y1ADJ = Y1ADJ*10.0 00016200 IF ( CARD(30:30).EQ.BLANK(1:1) ) Y1ADJ = Y1ADJ*10.0 00016300 XOLD = 0.0 00016400 YOLD = 0.0 00016500 DIST = 0.0 00016600 CNT = 0 00016700 C 00016800 C GO BACK TO READ AGAIN CARDS 00016900 C 00017001 10 CALL FORC (GM3D, 0, DAC, CARD, * 320 )00017200 COUT IF (S1CPCH (CARD, 8, XYA, 1, 3) .EQ. 0) GO TO 300 00017300 COUT IF (S1CPCH (CARD, 8, XYE, 1, 3) .EQ. 0) GO TO 100 00017400 COUT IF (S1CPCH (CARD, 8, SVR, 1, 3) .EQ. 0) GO TO 200 00017500 IF ( CARD(8:10).EQ.XYA(1:3) ) GO TO 300 00017600 IF ( CARD(8:10).EQ.XYE(1:3) ) GO TO 100 00017700 IF ( CARD(8:10).EQ.SVR(1:3) ) GO TO 200 00017800 GO TO 10 00018000 C 00018100 C PROCESS AN XYE CARD 00018200 C 00018300 100 CONTINUE 00018400 C 00018700 DO 110 III = 1, 2 00018800 COL = 21 00019000 IF (III .EQ. 2) COL = 51 00019100 C 00019300 C GET SHOT-RECEIVER X,Y COORDINATES 00019400 C 00019500 COUT IF (S1CPCH (CARD, COL+8, BLANK, 1, 8) .EQ. 0) GO TO 110 00019600 COUT IF (S1CPCH (CARD, COL+16, BLANK, 1, 8) .EQ. 0) GO TO 110 00019700 IF ( CARD(COL+ 8:COL+15).EQ.BLANK(1:8) ) GO TO 110 00019800 IF ( CARD(COL+16:COL+23).EQ.BLANK(1:8) ) GO TO 110 00019900 C 00020000 C COUNT HERE THE NUMBER OF X-Y POINTS READ 00020100 C 00020200 CNT = CNT + 1 00020300 XNEW= S1CVBN (CARD, COL+8, 8) / 10.0 00020500 COUT IF (S1CPCH (CARD, COL+15,BLANK, 1, 1) .EQ. 0)XNEW =XNEW * 10.0 00020600 IF ( CARD(COL+15:COL+15).EQ.BLANK(1:1) )XNEW =XNEW * 10.0 00020700 C 00020800 YNEW= S1CVBN (CARD, COL+16, 8) / 10.0 00020900 COUT IF (S1CPCH (CARD, COL+23,BLANK, 1, 1) .EQ. 0)YNEW =YNEW * 10.0 00021000 IF ( CARD(COL+23:COL+23).EQ.BLANK(1:1) )YNEW =YNEW * 10.0 00021100 C 00021200 IF((XOLD .EQ. 0.0) .AND. (YOLD .EQ. 0.0)) GO TO 120 00021300 C COMPUTE THE DISTANCE BETWEEN TWO SUCCESIIVE POINTS 00021400 C 00021500 XSQ = XNEW - XOLD 00021600 XSQ = XSQ*XSQ 00021700 YSQ = YNEW - YOLD 00021900 YSQ = YSQ*YSQ 00022000 DIST = DSQRT( XSQ + YSQ ) 00022200 C ACCUMULATE THE DISTANCE 00022301 CDIST = CDIST + DIST 00022400 C 00022500 C SAVE X , Y 00022601 120 CONTINUE 00022700 XOLD = XNEW 00022800 YOLD = YNEW 00022900 C 00023000 110 CONTINUE 00023100 C 00023200 C PROCESSING OF XYE CARD COMPLETE. READ NEXT CARD 00023300 GO TO 10 00023400 C 00023500 C READ A SVR CARD NOW. TO COLLECT X-Y FROM THAT CARD 00023600 C AND TOTAL UP THE DISTANCES. 00023700 200 CONTINUE 00023800 C 00023900 C COUNT HERE THE NUMBER OF SVR CARDS READ 00024000 C 00024100 CNT = CNT + 1 00024200 C 00024300 C COMPUTE X AND Y COORDINATES FOR SVR CARD. 00024400 C CHECK HERE IF THE FIRST SVR CARD IS TO BE ADJUSTED. 00024500 C 00024600 IF (FOCC .EQ. 1) GO TO 210 00024700 C 00025100 COUT CALL S1MVCH (CARD, 17, STATON, 1, 10) 00025200 STATON(1:10) = CARD(17:26) 00025300 C 00025400 C GET AZIMUTH ANGLE 00025500 C 00025600 COUT AZNS = BLNK 00025701 COUT CALL S1MVCH (CARD, 27, AZNS, 1, 1) 00025801 C 00025900 AZD = S1CVBN (CARD, 28, 3) 00026000 AZM = S1CVBN (CARD, 31, 2) 00026100 AZS = S1CVBN (CARD, 33, 2) 00026200 C 00026300 COUT AZEW = BLNK 00026401 COUT CALL S1MVCH (CARD, 35, AZEW, 1, 1) 00026501 C 00026600 OAZ = AZD + AZM / 60.0 + AZS / 3600.0 00026700 C 00026800 C SET X AND Y COORDINATES 00026900 C 00027000 O8X = S1CVBN (CARD, 50, 8) / 10.0 00027100 COUT IF (S1CPCH (CARD, 57,BLANK, 1, 1) .EQ. 0) O8X = O8X * 10.0 00027200 IF ( CARD(57:57) .EQ. BLANK(1:1) ) O8X = O8X * 10.0 00027300 C 00027400 O8Y = S1CVBN (CARD, 58, 8) / 10.0 00027500 COUT IF (S1CPCH (CARD, 65,BLANK, 1, 1) .EQ. 0) O8Y = O8Y * 10.0 00027600 IF ( CARD(65:65) .EQ. BLANK(1:1) ) O8Y = O8Y * 10.0 00027700 C 00027800 C SAVE THE X-Y COORDINATES OF CURRENTLY OCCUPIED STATION AND 00027900 C ITS AZIMUTH ANGLE 00028000 XOCC = O8X 00028100 YOCC = O8Y 00028200 OCCAZ = OAZ 00028300 TEMP1 = O8X 00028400 TEMP2 = O8Y 00028500 XNEW = 0.0 00028600 YNEW = 0.0 00028700 FOCC = 1 00028800 GO TO 280 00028900 C 00029000 210 CONTINUE 00029100 IF ( CNT .NE. 1 ) GO TO 220 00029200 C 00029300 C SAVE THE X-Y COORDINATES OF CURRENTLY OCCUPIED STATION AND 00029400 C ITS AZIMUTH ANGLE 00029500 XOCC = O8X 00029600 YOCC = O8Y 00029700 OCCAZ = OAZ 00029800 TEMP1 = O8X 00029900 TEMP2 = O8Y 00030000 TEMP3 = OBAZ 00030100 C 00030300 220 CONTINUE 00030400 C 00030500 C GET STATION NAME 00030600 C 00030700 COUT CALL S1MVCH (CARD, 17, STATON, 1, 10) 00030800 STATON(1:10) = CARD(17:26) 00030900 C 00031000 C CHECK IF THIS STATION WAS READ LAST TIME 00031100 C GET THE X-Y OF THE NEW SURVEY OCCUPIED STATION IF IT 00031200 C HAS CHANGED. 00031300 C 00031400 C NEED ALSO TO PICK UP NEW AZIMUTH. 00031500 C THIS WILL WORK ONLY IF THE LAST OBSERVED SURVEY 00031600 C STATION NOW BECOMES AN OCCUPIED SURVEY STATION. 00031700 C 00031800 COUT IF (S1CPCH (CARD, 16, LTR1, 3, 1) .NE. 0) GO TO 240 00031900 IF ( CARD(16:16).NE.LTR1(3:3) ) GO TO 240 00032000 IF ( CNT .EQ. 1 ) GO TO 230 00032100 XOCC = XNEW 00032200 YOCC = YNEW 00032300 OCCAZ = OBAZ 00032600 C 00032700 C CONVERT TO BACK-AZIMUTH 00032800 IF (OBAZ .GE. 180.0) OCCAZ = OCCAZ - 180.0 00032900 IF (OBAZ .LT. 180.0) OCCAZ = OCCAZ + 180.0 00033000 C 00033100 C A NEW OCC ST. IS READ WITHIN THE 2 XYA CARDS 00033200 C 00033300 230 CONTINUE 00033400 GO TO 280 00033500 C 00033600 240 CONTINUE 00033700 C CHECK FOR FIELD ANGLE 00033800 C 00033900 COUT IF (S1CPCH (CARD, 28,BLANK, 1, 7) .EQ. 0) GO TO 250 00034000 IF ( CARD(28:34).EQ.BLANK(1:7) ) GO TO 250 00034100 C 00034200 COUT FANS = BLNK 00034301 COUT CALL S1MVCH (CARD, 27, FANS, 1, 1) 00034401 C 00034500 FAD = S1CVBN (CARD, 28, 3) 00034600 FAM = S1CVBN (CARD, 31, 2) 00034700 FAS = S1CVBN (CARD, 33, 2) 00034800 C 00034900 COUT FAEW = BLNK 00035001 COUT CALL S1MVCH (CARD, 35, FAEW, 1, 1) 00035101 C 00035200 C CALCULATE STATION AZIMUTH 00035300 C 00035400 OBAZ = (OCCAZ-360.0) + FAD + FAM / 60.0 + FAS / 3600.0 00035500 IF (OBAZ .LT. 0.0) OBAZ = OBAZ + 360.0 00035600 IF (OBAZ .GT. 360.0) OBAZ = OBAZ - 360.0 00035700 C 00035800 C GET ZENITH ANGLE 00035900 C 00036000 COUT0 IF (S1CPCH (CARD, 36,BLANK, 1, 6) .EQ. 0) GO TO 260 00036100 250 IF ( CARD(36:41).EQ.BLANK(1:6) ) GO TO 260 00036200 ZNAD = S1CVBN (CARD, 36, 4) 00036300 ZNAM = S1CVBN (CARD, 40, 2) 00036400 ZNAS = S1CVBN (CARD, 42, 2) 00036500 OBZNA = ZNAD + ZNAM / 60.0 + ZNAS / 3600.0 00036700 C 00036800 C GET SLOPE DISTANCE 00036900 C 00037000 COUT IF (S1CPCH (CARD, 44,BLANK, 1, 6) .EQ. 0) GO TO 260 00037100 IF ( CARD(44:49).EQ.BLANK(1:6) ) GO TO 260 00037200 SLOPED = S1CVBN (CARD, 44, 6) / 10.0 00037300 COUT IF (S1CPCH (CARD, 49,BLANK, 1, 1) .EQ. 0) SLOPED = SLOPED * 10.0 00037400 IF ( CARD(49:49).EQ.BLANK(1:1) ) SLOPED = SLOPED * 10.0 00037500 C COMPUTE HORIZONTAL DISTANCE 00037600 HORZD = SLOPED * SIN(OBZNA / DPR) 00037700 C 00037800 C CALCULATE X AND Y COORDINATES 00037900 C 00038000 XOBS =XOCC + SIN(OBAZ/DPR) * HORZD 00038100 YOBS =YOCC + COS(OBAZ/DPR) * HORZD 00038200 C 00038400 260 CONTINUE 00038500 XNEW = XOBS 00038600 YNEW = YOBS 00038700 C 00038800 IF((XOLD .EQ. 0.0) .AND. (YOLD .EQ. 0.0)) GO TO 280 00038900 C COMPUTE THE DISTANCE BETWEEN TWO SUCCESIIVE POINTS 00039000 C 00039100 XSQ = XNEW - XOLD 00039200 XSQ = XSQ*XSQ 00039300 YSQ = YNEW - YOLD 00039500 YSQ = YSQ*YSQ 00039600 DIST = DSQRT( XSQ + YSQ ) 00039800 C 00040000 C ACCUMULATE THE DISTANCE 00040101 CDIST = CDIST + DIST 00040200 C 00040300 C SAVE X , Y FROM SVR CARD 00040401 280 CONTINUE 00040600 XOLD = XNEW 00040900 YOLD = YNEW 00041000 C 00041100 C PROCESSING OF THE SVR CARD COMPLETE 00041200 C GO BACK TO READ ANOTHER CARD 00041300 C 00041400 GO TO 10 00041700 C 00041800 C PROCESSING FOR THE SECOND XYA CARD NOW 00041900 C 00042000 300 CONTINUE 00042100 C IF NO X-Y ADJUSTMENT GIVEN ,WRITE AN ERROE MESSAGE 00042200 COUT IF (S1CPCH (CARD, 11, BLANK, 1,10) .EQ. 0) GO TO 370 00042300 COUT IF (S1CPCH (CARD, 21, BLANK, 1,10) .EQ. 0) GO TO 370 00042400 IF ( CARD(11:20).EQ.BLANK(1:10) ) GO TO 370 00042500 IF ( CARD(21:30).EQ.BLANK(1:10) ) GO TO 370 00042600 C 00042700 C IF THERE ARE XYA CARDS BACK-TO-BACK, CHECK THE VALUE OF CNT 00042800 C AND GO BACK TO THE START 00042900 C 00043000 IF ( CNT .EQ. 0 ) GO TO 360 00043100 C 00043400 X2ADJ = S1CVBN (CARD,11 ,10) / 10.0 00043500 COUT IF (S1CPCH (CARD, 20,BLANK, 1, 1) .EQ. 0) X2ADJ = X2ADJ*10.0 00043600 IF ( CARD(20:20).EQ.BLANK(1:1) ) X2ADJ = X2ADJ*10.0 00043700 C 00043800 Y2ADJ = S1CVBN (CARD,21 ,10) / 10.0 00043900 COUT IF (S1CPCH (CARD, 30,BLANK, 1, 1) .EQ. 0) Y2ADJ = Y2ADJ*10.0 00044000 IF ( CARD(30:30).EQ.BLANK(1:1) ) Y2ADJ = Y2ADJ*10.0 00044100 C 00044300 XFACT = ( X2ADJ - X1ADJ )/ CDIST 00044400 YFACT = ( Y2ADJ - Y1ADJ )/ CDIST 00044500 C 00044700 GO TO 350 00044800 C 00044900 C ERROR MESSAGE HERE 00045000 C 00045100 320 CONTINUE 00045200 C 00045500 DAC = DAPR 00045600 C 00045700 C IF ONLY ONE XYA CARD READ, SET ONECARD FLAG 00045800 C 00045900 IF ( NOCXYA .EQ. 1 ) ONECRD = 1 00046000 C IF NO XYA CARDS READ AFTER COMPLETING THE LAST XYACARD PROCESSING 00046100 C SET THE XYAFLG TO ZERO 00046200 XYAFLG = 0 00046300 C 00046400 C FOR SVR CARDS GIVE BACK THE X Y OF OCC ST. AND ITS AZIMUTH 00046500 O8X = TEMP1 00046600 O8Y = TEMP2 00046700 OBAZ = TEMP3 00046800 C 00046900 C GO BACK TO READ AS USUAL 00047000 C 00047100 GO TO 360 00047200 C 00047300 370 WRITE(IPR, 1370) 00047400 1370 FORMAT('0*** NO ADJUSTMENT ON XYA CARD *** ') 00047500 ERRFLG = 0 00047600 GO TO 360 00047700 C 00047800 C PROCESSING OF A PAIR OF XYA CARD COMPLETE.RESET THE DISC ADDRESS, 00047900 C INITAILIZE THE XYAFLG TO UPDATE XY. 00048000 C 00048100 350 CONTINUE 00048200 XYAFLG = 1 00048300 XLAST=0.0 00048400 YLAST=0.0 00048500 C 00048600 C FOR SVR CARDS GIVE BACK THE X Y OF OCC ST. AND ITS AZIMUTH 00048700 O8X = TEMP1 00048800 O8Y = TEMP2 00048900 OBAZ = TEMP3 00049000 360 CONTINUE 00049100 C 00049200 C RESET THE DISC ADDRESS,DIST,CUDIST 00049300 DAC = DAPR 00049400 DIST = 0.0 00049500 CUDIST = 0.0 00049600 C 00049700 C GO BACK TO SPSRVY 00049800 C 00049900 RETURN 00050000 END 00060000