CTITLESAGXYE -- INTERPRETATION OF XYE CARDS BY GM3D 00000100 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR P. COOPER 00000200 CA DESIGNER P. COOPER 00000300 CA LANGUAGE FORTRAN 00000400 CA SYSTEM CRAY (SEE IBM) 00000600 CA WRITTEN 10-06-80 00000700 C REVISED 11-24-80 SAS - MODIFIED FOR GM3D 'XYE' CARD FORMAT 00000800 C CHANGE. 00000900 C ALSO ADDED CHECK TO OMIT 'XYE' CARDS WITH 00001000 C UNCODED SHOT/RECEIVER NO. FIELDS. 00001100 C REVISED 04-20-82 NTS - MODIFIED FOR GM3D 'XYA' CARD FORMAT 00001200 C THAT WILL ADJUST X-Y COORDINATES OF SHOT 00001300 C POINTS AND RECEIVER STATIONS. 00001400 C REVISED 08-11-82 PKC - MAKE SURE RVMNDX,RVNRVS,SPMNDX, 00001500 C AND SPMXDX ARE UPDATED IF ONLY ELEV. INPUT. 00001600 C REVISED 08-16-82 PKC - CORRECTED UPDATE OF ABOVE VALUES. 00001700 C REVISED 08-19-82 PKC - CORRECTED TYPOGRAPHICAL ERROR. 00001800 C REVISED 06-08-82 CMP - UPDATE RVLSNO IF ONLY ELEV. INPUT. 00001900 C REVISED 06-22-83 CMP - FIX BUG IF SOME X-Y RCVR COORD.MISSING00002000 C REVISED 07-08-83 CMP - FIX BUG IF NO RCVR STNS. INPUT. 00002100 C REVISED 07-10-84 GRAY - ADDED ARGUMENT MAXRVS (LENGTH OF WORK00002200 C ARRAY SPELEV) TO MAKE SUBROUTINE DYNAMIC. 00002300 C REVISED 03-01-85 KNIGHT-DUAL IBM/CRAY VERSION. 00002400 C REVISED 10-22-86 PARKER-OUTPUT SHOT ELEVATIONS IN RLOC ORDER 00002500 C IN SPE PARM RECORDS. 00002600 C REVISED 02-24-89 TRULOCK-LEAVE DATA IN SPELEV AT RETURN. 00002700 C CHANGE MAXRVS TO MAXSPS - LENGTH OF SPELEV. 00002800 C DO NOT WRITE SPELEV TO SEISPARM FILE. 00002900 C REVISED 11-13-89 KNIGHT-FOR CRAY CFT77 COMPATIBILITY. 00003002 C REVISED MO-DA-YR BY PROGRAMMER FOR REASON. 00003100 CA 00003200 CA 00003300 CA CALL SAGXYE (KPNA, KPRNO, IPR, ERR, NOCXYE, BLNKC, CARD, ASPNO, 00003400 CA * MNRVI, MNRV, RVX, RVY, RVLSNO, RVELEV, RVMNDX,RVNRVS,00003500 CA * SPX, SPY, WORK, SPELEV, SPMNDX, SPMXDX, INDEX, DAP, 00003600 CA * MAXRVS ) 00003700 CA 00003800 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00003900 CA 00004000 CA IN KPNA A4 PROCESS NAME 00004100 CA IN KPRNO I4 PROCESS NO. 00004200 CA IN IPR I4 PRINTER UNIT NO. 00004300 CA IN/OUT ERR I4 ERROR INDICATOR 00004400 CA IN/OUT NOCXYE I4 NUMBER OF XYE CARDS READ 00004500 CA IN BLNKC A4 BLANK CARD IMAGE 00004600 CA IN CARD A4 CARD IMAGE WORK AREA ARRAY 00004700 CA IN ASPNO I4 SHOTPOINT NUMBER ARRAY 00004800 CA IN MNRVI I4 MINIMUM RECEIVER BASE INDEX 00004900 CA IN MNRV I4 MINIMUM RECEIVER 00005000 CA IN/OUT RVX R8 RECEIVER STATION X-COOR 00005100 CA IN/OUT RVY R8 RECEIVER STATION Y-COOR 00005200 CA IN/OUT RVLSNO R4 RECEIVER STATION LINE NO. 00005300 CA IN/OUT RVELEV I4 RECEIVER STATION ELEVATIONS 00005400 CA IN/OUT RVMNDX I4 RECEIVER MINIMUM INDEX 00005500 CA IN/OUT RVNRVS I4 RECEIVER NUMBER OF RECEIVERS 00005600 CA IN/OUT SPX R8 SHOTPOINT X-COOR. 00005700 CA IN/OUT SPY R8 SHOTPOINT Y-COOR. 00005800 CA IN/OUT WORK I4 SHOTPOINT INDEX ARRAY 00005900 CA IN/OUT SPELEV I4 SHOTPOINT ELEVATION WORK AREA 00006000 CA IN/OUT SPMNDX I4 SHOTPOINT MINIMUM INDEX FOUND 00006100 CA IN/OUT SPMXDX I4 SHOTPOINT MAXIMUM INDEX FOUND 00006200 CA IN/OUT INDEX I4 SHOTPOINT MAXIMUM INDEX 00006300 CA IN/OUT DAP I4 DISK ADDRESS FOR PARAMETER RECORD WRITE 00006400 CA IN MAXSPS I4 LENGTH OF WORK ARRAY SPELEV (WORDS) 00006500 CA 00006600 CA 00006700 CA SAGXYE IS CALLED BY PREPARATION ROUTINE 'GM3D' TO READ AND 00006800 CA INTERPRET THE 'XYE' CARDS. THIS CARD GIVES RECEIVER AND SHOT- 00006900 CA POINT X-Y COORDINATES AND ELEVATIONS. THE X-Y COORDINATES ARE 00007000 CA PUT IN THE APPROPRIATE ARRAYS (RVX, RVY, SPX, SPY). THE SHOT- 00007100 CA POINT ELEVATIONS ARE WRITTEN OUT AS 'GM3D' PARAMETER RECORDS. 00007200 CA THE RECEIVER ELEVATIONS ARE PASSED BACK TO 'GM3D'. 00007300 CAEND 00007400 CC EJECT 00007500 SUBROUTINE SAGXYE (KPNA, KPRNO, IPR, ERR, NOCXYE, BLNKC, CARD, 00007600 * ASPNO, MNRVI, MNRV, RVX, RVY, RVLSNO, RVELEV, RVMNDX,RVNRVS, 00007700 * SPX, SPY, WORK, SPELEV, SPMNDX, SPMXDX, INDEX, DAP, MAXSPS) 00007800 C 00007900 C 00008000 IMPLICIT INTEGER (A-Z) 00008100 C EXTERNAL S1ATP 00008201 C 00008300 C REAL ARRAYS IN PARAMETER LIST. 00008400 C 00008500 REAL RVLSNO(1) 00008600 C 00008700 DOUBLE PRECISION RVX (1) 00008800 DOUBLE PRECISION RVY (1) 00008900 DOUBLE PRECISION SPX (1) 00009000 DOUBLE PRECISION SPY (1) 00009100 C 00009200 C CHARACTER ARRAYS IN PARAMETER LIST. 00009300 C 00009400 CHARACTER*80 BLNKC 00009500 CHARACTER*80 CARD 00009600 C 00009700 C INTEGER ARRAYS IN PARAMETER LIST. 00009800 C 00009900 INTEGER RVELEV (1) 00010000 INTEGER SPELEV (1) 00010100 INTEGER WORK (1) 00010200 INTEGER ASPNO (1) 00010300 C 00010400 C INTEGER ARRAYS -- LOCAL 00010500 C 00010600 INTEGER DENTRY (104) 00010700 INTEGER DATTR (96) 00010800 C 00010900 C REAL VARIABLES AND CONSTANTS 00011000 C 00011100 DOUBLE PRECISION FLOATN 00011200 DOUBLE PRECISION RVXPRT 00011500 DOUBLE PRECISION RVYPRT 00011600 C 00011700 REAL SPXPRT 00011800 REAL SPYPRT 00011900 C 00012000 C CHARACTER VARIABLES AND CONSTANTS 00012100 C 00012200 CHARACTER*4 XYA 00012300 CHARACTER*4 XYE 00012400 CHARACTER*16 RVNAM 00012500 CHARACTER*16 SPNAM 00012600 C 00012700 C********** ADD CODE FOR XYA ********** 00012800 C 00012900 DOUBLE PRECISION XFACT 00013000 DOUBLE PRECISION YFACT 00013100 DOUBLE PRECISION DIST 00013200 DOUBLE PRECISION CDIST 00013300 DOUBLE PRECISION CUDIST 00013400 DOUBLE PRECISION XLAST 00013500 DOUBLE PRECISION YLAST 00013600 DOUBLE PRECISION XCURR 00013700 DOUBLE PRECISION YCURR 00013800 DOUBLE PRECISION X1ADJ 00013900 DOUBLE PRECISION Y1ADJ 00014000 DOUBLE PRECISION O8X 00014100 DOUBLE PRECISION O8Y 00014200 DOUBLE PRECISION XSQ 00014300 DOUBLE PRECISION YSQ 00014400 C 00014500 C 00014600 C********** END CODE FOR XYA ********** 00014700 C 00014800 C INTEGER VARIABLES AND CONSTANTS 00014900 C 00015000 INTEGER GM3D 00015100 INTEGER SPE 00015200 C 00015300 C********** ADD CODE FOR XYA ********** 00015400 C 00015500 INTEGER XYAFLG 00015600 INTEGER ONECRD 00015700 INTEGER NOCXYA 00015800 INTEGER ERRFLG 00015900 INTEGER FOC 00016000 C 00016100 C********** END CODE FOR XYA ********** 00016200 C 00016300 EQUIVALENCE (DCTYP ,DENTRY(03)) 00016400 EQUIVALENCE (SRCV ,DENTRY(04)) 00016500 CE EQUIVALENCE ( ,DENTRY(05)) 00016600 EQUIVALENCE (NOPAR ,DENTRY(06)) 00016700 CE EQUIVALENCE ( ,DENTRY(07)) 00016800 CE EQUIVALENCE ( ,DENTRY(08)) 00016900 EQUIVALENCE (DATTR(1) ,DENTRY(09)) 00017000 C 00017100 C INITIALIZATION 00017200 C 00017300 DATA DATTR / 96*0/ 00017400 DATA DENTRY /104*0/ 00017500 DATA ERRFLG / 1/ 00017600 DATA FOC / 1/ 00017700 DATA GM3D /'GM3D'/ 00017800 DATA NOCXYA /0 / 00017900 DATA ONECRD /0 / 00018000 DATA SPE /'SPE '/ 00018100 DATA XYA /'XYA '/ 00018200 DATA XYE /'XYE '/ 00018300 DATA XYAFLG /0 / 00018400 C 00018500 C INITIALIZATION AREA 00018600 C 00018700 IF (1.EQ.2) CALL S1ATP 00018801 C 00018901 DA1 = 1 00019000 LERR = ERR 00019100 RVXY = 0 00019200 RVEL = 0 00019300 RCVMIN = 0 00019400 SPXY = 0 00019500 SPEL = 0 00019600 SPMNSV = SPMNDX 00019700 SPMXSV = SPMXDX 00019800 DENTRY(1) = GM3D 00019900 DENTRY(2) = 0 00020000 C 00020100 C 00020200 CALL ARSET (SPELEV(1), MAXSPS, -9999) 00020300 C 00020400 C GET FIRST XYE CARD 00020500 C 00020600 10 CALL FORC (KPNA, KPRNO, DA1, CARD, *2000) 00020700 C********** ADD CODE FOR XYA ********** 00020800 C 00020900 COUT IF (S1CPCH (CARD, 8, 'XYA', 1, 3) .EQ. 0) GO TO 200 00021000 IF ( CARD(8:10).EQ.XYA(1:3) ) GO TO 200 00021100 C 00021200 C********** END CODE FOR XYA ********** 00021300 COUT IF (S1CPCH (CARD, 8, 'XYE', 1, 3) .NE. 0) GO TO 10 00021400 COUT IF (S1CPCH (CARD,11, BLNKC, 1, 10) .EQ. 0) GO TO 10 00021500 IF ( CARD(8:10).NE.XYE(1:3) ) GO TO 10 00021600 IF ( CARD(11:20).EQ.BLNKC(1:10) ) GO TO 10 00021700 C 00021800 NOCXYE = NOCXYE + 1 00021900 FNDFLG = 0 00022000 SPFLG = 0 00022100 RVXPRT = 0.0 00022200 RVYPRT = 0.0 00022300 SPXPRT = 0.0 00022400 SPYPRT = 0.0 00022500 RVELPT = 0 00022600 SPELPT = 0 00022700 C 00022800 COUT CALL S1MVCH (BLNKC, 1, RVNAM, 1, 16) 00022900 COUT CALL S1MVCH (BLNKC, 1, SPNAM, 1, 16) 00023000 RVNAM(1:16) = BLNKC(1:16) 00023100 SPNAM(1:16) = BLNKC(1:16) 00023200 C 00023300 C CHECK IF RECEIVER INFORMATION 00023400 C 00023500 COUT IF (S1CPCH(CARD,11,BLNKC,1,5) .EQ. 0) GO TO 50 00023600 IF ( CARD(11:15).EQ.BLNKC(1:5) ) GO TO 50 00023700 RCVNO = S1CVBN (CARD, 11, 5) 00023800 C 00023900 C INTERPRET RECEIVER STATION NAME 00024000 C 00024100 COUT0 CALL S1MVCH (CARD, 21, RVNAM, 1, 8) 00024200 20 RVNAM(1:8) = CARD(21:28) 00024300 C 00024400 C COMPUTE INDEX INTO RECEIVER ARRAYS 00024500 C 00024600 RVINDX = RCVNO - MNRV + MNRVI 00024700 C 00024800 C CHECK FOR X-Y COORDINATES 00024900 C 00025000 COUT IF (S1CPCH(CARD,29,BLNKC,1,8) .EQ. 0) GO TO 30 00025100 COUT IF (S1CPCH(CARD,37,BLNKC,1,8) .EQ. 0) GO TO 30 00025200 IF ( CARD(29:36).EQ.BLNKC(1:8) ) GO TO 30 00025300 IF ( CARD(37:44).EQ.BLNKC(1:8) ) GO TO 30 00025400 FNDFLG = 1 00025500 RVXY = 1 00025600 C 00025700 FLOATN = S1CVBN(CARD,29,8) 00025800 COUT IF (S1CPCH(CARD,36,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00025900 IF ( CARD(36:36).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00026000 RVX(RVINDX) = FLOATN / 10. 00026100 RVXPRT = RVX(RVINDX) 00026200 FLOATN = S1CVBN(CARD,37,8) 00026300 COUT IF (S1CPCH(CARD,44,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00026400 IF ( CARD(44:44).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00026500 RVY(RVINDX) = FLOATN / 10. 00026600 RVYPRT = RVY(RVINDX) 00026700 C****** ADD CODE FOR XYA ************** 00026800 C 00026900 C IF ONLY ONE XYA CARD READ ADJUST XY HERE 00027000 IF ( ONECRD .EQ. 1 ) RVX(RVINDX) = RVX(RVINDX) + X1ADJ 00027100 IF ( ONECRD .EQ. 1 ) RVY(RVINDX) = RVY(RVINDX) + Y1ADJ 00027200 IF ( ONECRD .EQ. 1 ) RVXPRT = RVX(RVINDX) 00027300 IF ( ONECRD .EQ. 1 ) RVYPRT = RVY(RVINDX) 00027400 C 00027500 C 00027600 IF ( ONECRD .EQ. 1 ) GO TO 250 00027700 C 00027800 C 00027900 IF ( XYAFLG .NE. 1 ) GO TO 250 00028000 CNT = CNT - 1 00028100 C SAVE THE CURRENT X-Y BEFORE THE ADJUSTMENT 00028200 C 00028300 C 00028400 XCURR = RVX(RVINDX) 00028500 YCURR = RVY(RVINDX) 00028600 C 00028700 C COMPUTE THE DISTANCE AND UPDATE CUDIST 00028800 C 00028900 IF ( XLAST .EQ. 0.0 .AND. YLAST .EQ. 0.0 ) GO TO 240 00029000 C 00029100 XSQ = XCURR-XLAST 00029200 XSQ = XSQ*XSQ 00029300 C 00029400 YSQ = YCURR-YLAST 00029500 YSQ = YSQ*YSQ 00029600 C 00029700 DIST = DSQRT ( XSQ + YSQ ) 00029800 C 00029900 C 00030000 CUDIST = CUDIST + DIST 00030100 C 00030200 C 00030300 240 CONTINUE 00030400 RVX(RVINDX) = RVX(RVINDX) + X1ADJ + CUDIST*XFACT 00030500 RVY(RVINDX) = RVY(RVINDX) + Y1ADJ + CUDIST*YFACT 00030600 RVXPRT = RVX(RVINDX) 00030700 RVYPRT = RVY(RVINDX) 00030800 C 00030900 C 00031000 C 00031100 C RESET THE XYAFLG WHEN CDIST AND CUDIST BECOME EQUAL 00031200 C 00031300 IF ( CUDIST .EQ. CDIST ) XYAFLG = 0 00031400 IF ( CNT .EQ. 0 ) XYAFLG = 0 00031500 C 00031600 C SET ONE XYA CARD ONLY FLAG HERE 00031700 C 00031800 ONECRD = 0 00031900 XLAST = XCURR 00032000 YLAST = YCURR 00032100 250 CONTINUE 00032200 C 00032300 C****** END CODE FOR XYA ************** 00032400 C 00032500 C UPDATE RVMNDX, RVLSNO, RVNRVS 00032600 C 00032700 RVLSNO(RVINDX) = RCVNO 00032800 30 IF (RVINDX .LT. RVMNDX) RVMNDX = RVINDX 00032900 IF (RVINDX .EQ. RVMNDX) RCVMIN = RCVNO 00033000 IF (RVINDX .GT. RVNRVS) RVNRVS = RVINDX 00033100 C 00033200 C CHECK FOR ELEVATION 00033300 C 00033400 COUT IF (S1CPCH(CARD,45,BLNKC,1,6) .EQ. 0) GO TO 40 00033500 IF ( CARD(45:50).EQ.BLNKC(1:6) ) GO TO 40 00033600 FNDFLG = 1 00033700 RVEL = 10 00033800 FLOATN = S1CVBN(CARD,45,6) 00033900 COUT IF (S1CPCH(CARD,50,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00034000 IF ( CARD(50:50).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00034100 RVELEV(RVINDX) = INT(FLOATN / 10. + 0.0001) 00034202 RVELPT = RVELEV(RVINDX) 00034300 C 00034400 C CHECK IF ANY RECEIVER INFO. READ 00034500 C 00034600 40 IF (FNDFLG .NE. 1) GO TO 1120 00034700 C 00034800 C CHECK FOR SHOTPOINT INFORMATION 00034900 C 00035000 COUT0 IF (S1CPCH(CARD,16,BLNKC,1,5) .EQ. 0) GO TO 100 00035100 50 IF ( CARD(16:20).EQ.BLNKC(1:5) ) GO TO 100 00035200 SRVNO = S1CVBN (CARD, 16, 5) 00035300 C 00035400 C INTERPRET SHOTPOINT NAME 00035500 C 00035600 COUT CALL S1MVCH (CARD, 51, SPNAM, 1, 8) 00035700 SPNAM(1:8) = CARD(51:58) 00035800 C 00035900 C COMPUTE INDEX INTO SHOTPOINT ARRAYS 00036000 C 00036100 DO 60 I = 1, INDEX 00036200 IF (SRVNO .EQ. ASPNO(I)) GO TO 70 00036300 60 CONTINUE 00036400 C 00036500 C PRINT INVALID SHOTPOINT NUMBER IF NOT FOUND 00036600 C 00036700 LERR = LERR + 1 00036800 WRITE (IPR, 9130) CARD 00036900 GO TO 10 00037000 C 00037100 70 SPINDX = WORK(I) 00037200 SPIX = I 00037300 C 00037400 C CHECK FOR X-Y COORDINATES 00037500 C 00037600 COUT IF (S1CPCH(CARD,59,BLNKC,1,8) .EQ. 0) GO TO 80 00037700 COUT IF (S1CPCH(CARD,67,BLNKC,1,8) .EQ. 0) GO TO 80 00037800 IF ( CARD(59:66).EQ.BLNKC(1:8) ) GO TO 80 00037900 IF ( CARD(67:74).EQ.BLNKC(1:8) ) GO TO 80 00038000 FNDFLG = FNDFLG + 2 00038100 SPFLG = 1 00038200 SPXY = 100 00038300 C 00038400 FLOATN = S1CVBN(CARD,59,8) 00038500 COUT IF (S1CPCH(CARD,66,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00038600 IF ( CARD(66:66).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00038700 SPX(SPINDX) = FLOATN / 10. 00038800 SPXPRT = SPX(SPINDX) 00038900 FLOATN = S1CVBN(CARD,67,8) 00039000 COUT IF (S1CPCH(CARD,74,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00039100 IF ( CARD(74:74).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00039200 SPY(SPINDX) = FLOATN / 10. 00039300 SPYPRT = SPY(SPINDX) 00039400 C****** ADD CODE FOR XYA ************** 00039500 C 00039600 C IF ONLY ONE XYA CARD READ ADJUST XY HERE 00039700 IF ( ONECRD .EQ. 1 ) SPX(SPINDX) = SPX(SPINDX) + X1ADJ 00039800 IF ( ONECRD .EQ. 1 ) SPY(SPINDX) = SPY(SPINDX) + Y1ADJ 00039900 IF ( ONECRD .EQ. 1 ) SPXPRT = SPX(SPINDX) 00040000 IF ( ONECRD .EQ. 1 ) SPYPRT = SPY(SPINDX) 00040100 C 00040200 C 00040300 IF ( ONECRD .EQ. 1 ) GO TO 350 00040400 C 00040500 C 00040600 IF ( XYAFLG .NE. 1 ) GO TO 350 00040700 CNT = CNT - 1 00040800 C SAVE THE CURRENT X-Y BEFORE THE ADJUSTMENT 00040900 C 00041000 C 00041100 XCURR = SPX(SPINDX) 00041200 YCURR = SPY(SPINDX) 00041300 C 00041400 C COMPUTE THE DISTANCE AND UPDATE CUDIST 00041500 C 00041600 IF ( XLAST .EQ. 0.0 .AND. YLAST .EQ. 0.0 ) GO TO 340 00041700 C 00041800 XSQ = XCURR-XLAST 00041900 XSQ = XSQ*XSQ 00042000 C 00042100 YSQ = YCURR-YLAST 00042200 YSQ = YSQ*YSQ 00042300 C 00042400 DIST = DSQRT ( XSQ + YSQ ) 00042500 C 00042600 C 00042700 CUDIST = CUDIST + DIST 00042800 C 00042900 340 CONTINUE 00043000 SPX(SPINDX) = SPX(SPINDX) + X1ADJ + CUDIST*XFACT 00043100 SPY(SPINDX) = SPY(SPINDX) + Y1ADJ + CUDIST*YFACT 00043200 C 00043300 SPXPRT = SPX(SPINDX) 00043400 SPYPRT = SPY(SPINDX) 00043500 C 00043600 C 00043700 C RESET THE XYAFLG WHEN CDIST AND CUDIST BECOME EQUAL 00043800 C 00043900 IF ( CUDIST .EQ. CDIST ) XYAFLG = 0 00044000 IF ( CNT .EQ. 0 ) XYAFLG = 0 00044100 C 00044200 XLAST = XCURR 00044300 YLAST = YCURR 00044400 350 CONTINUE 00044500 C 00044600 C SET ONE XYA CARD FLAG HERE 00044700 ONECRD = 0 00044800 C 00044900 C****** END CODE FOR XYA ************** 00045000 C 00045100 C UPDATE SPMNDX(MIN. INDEX) AND SPMXDX(MAX. INDEX) 00045200 C 00045300 WORK(I) = - WORK(I) 00045400 IF (I .LT. SPMNDX) SPMNDX = I 00045500 IF (I .GT. SPMXDX) SPMXDX = I 00045600 C 00045700 80 IF (I .LT. SPMNSV) SPMNSV = I 00045800 IF (I .GT. SPMXSV) SPMXSV = I 00045900 C 00046000 C CHECK FOR ELEVATION 00046100 C 00046200 COUT IF (S1CPCH(CARD,75,BLNKC,1,6) .EQ. 0) GO TO 90 00046300 IF ( CARD(75:80).EQ.BLNKC(1:6) ) GO TO 90 00046400 IF (FNDFLG .LE. 1) FNDFLG = FNDFLG + 2 00046500 SPEL = 1000 00046600 SPFLG = 1 00046700 FLOATN = S1CVBN(CARD,75,6) 00046800 COUT IF (S1CPCH(CARD,80,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00046900 IF ( CARD(80:80).EQ.BLNKC(1:1) ) FLOATN = FLOATN * 10. 00047000 SPELEV(SPIX) = INT(FLOATN / 10. + 0.0001) 00047102 SPELPT = SPELEV(SPIX) 00047200 C 00047300 C CHECK IF ANY SHOTPOINT INFO. READ 00047400 C 00047500 90 IF (SPFLG .EQ. 0) GO TO 1130 00047600 C 00047700 C CHECK IF ANY INFO. ON CARD 00047800 C 00047900 100 IF (FNDFLG .EQ. 0) GO TO 1101 00048000 C 00048100 C PRINT OF INPUT VALUES 00048200 C 00048300 IF (NOCXYE .EQ. 1) WRITE (IPR, 9200) 00048400 IF (FNDFLG .EQ. 1) 00048500 *WRITE (IPR, 9210) RCVNO, RVNAM, RVXPRT, RVYPRT, RVELPT, 00048600 * SPNAM, SPXPRT, SPYPRT, SPELPT 00048700 C 00048800 IF (FNDFLG .EQ. 2) 00048900 *WRITE (IPR, 9220) SRVNO, RVNAM, RVXPRT, RVYPRT, RVELPT, 00049000 * SPNAM, SPXPRT, SPYPRT, SPELPT 00049100 C 00049200 IF (FNDFLG .EQ. 3) 00049300 *WRITE (IPR, 9230) RCVNO, SRVNO, RVNAM, RVXPRT, RVYPRT, RVELPT, 00049400 * SPNAM, SPXPRT, SPYPRT, SPELPT 00049500 GO TO 10 00049600 C********** ADD CODE FOR XYA ********** 00049700 C 00049800 C A XYA CARD IS READ WHEN WE GET HERE. 00049900 C 00050000 200 CONTINUE 00050100 C XYA CARD WAS READ WHEN WE GET HERE 00050200 C 00050300 C 00050400 C 00050500 C 00050600 C READ AND STORE THE ADJUSTMENT FROM THE FIRST XYA CARD 00050700 C 00050800 X1ADJ = S1CVBN(CARD,11,10)/10.0 00050900 COUT IF (S1CPCH(CARD,20,BLNK,1,1) .EQ. 0) X1ADJ = X1ADJ*10.0 00051000 IF ( CARD(20:20).EQ.BLNKC(1:1) ) X1ADJ = X1ADJ*10.0 00051100 Y1ADJ = S1CVBN(CARD,21,10)/10.0 00051200 COUT IF (S1CPCH(CARD,30,BLNK,1,1) .EQ. 0) Y1ADJ = Y1ADJ*10.0 00051300 IF ( CARD(30:30).EQ.BLNKC(1:1) ) Y1ADJ = Y1ADJ*10.0 00051400 ERRFLG = 1 00051500 DAC = DA1 00051600 C CALL THE SUBROUTINE SAGXYA HERE 00051700 C 00051800 C 00051900 CALL SAGXYA(KPNA,KPRNO,IPR,DAC,NOCXYA,CDIST,CUDIST,CARD,CNT, 00052000 * FOC,XYAFLG,O8X,O8Y,OAZ,OBAZ,XFACT,YFACT,ONECRD, 00052100 * ERRFLG) 00052200 C 00052300 C GO BACK TO READ AS USUAL 00052400 XLAST = 0.0 00052500 YLAST = 0.0 00052600 DA1 = DAC 00052700 C 00052800 C 00052900 C 00053000 IF ( ERRFLG .EQ. 0 ) GO TO 1101 00053100 C 00053200 C GO BACK TO READ AS USUAL 00053300 C 00053400 GO TO 10 00053500 C 00053600 C 00053700 C 00053800 C********** END CODE FOR XYA ********** 00053900 C 00054000 C 00054100 C 00054200 C ERROR MESSAGES 00054300 C 00054400 1101 WRITE (IPR, 9140) CARD 00054500 LERR = LERR + 1 00054600 GO TO 10 00054700 C 00054800 1120 LERR = LERR + 1 00054900 WRITE (IPR, 9120) CARD 00055000 GO TO 10 00055100 C 00055200 1130 LERR = LERR + 1 00055300 WRITE (IPR, 9150) CARD 00055400 GO TO 10 00055500 C 00055600 CTJT 1140 ERR = ERR + 1 00055700 CTJT WRITE (IPR, 9160) 00055800 CTJT GO TO 2020 00055900 C 00056000 C 00056100 2000 ERR = LERR 00056200 NOCXYE = RVXY + RVEL + SPXY + SPEL 00056300 C 00056400 IF (RCVMIN .NE.0) RVLSNO(RVMNDX) = RCVMIN 00056500 C 00056600 CTJT IF (SPEL .NE. 1000) GO TO 2020 00056700 CTJT DCTYP = SPE 00056800 CTJT NOPAR = 96 00056900 C 00057000 CTJT DO 2010 OUTNDX = SPMNSV, SPMXSV, 96 00057100 CTJT IF (OUTNDX+NOPAR-1 .GT. SPMXSV) NOPAR = SPMXSV-OUTNDX+1 00057200 CTJT SRCV = ASPNO(OUTNDX) 00057300 C WRTNDX = IABS(WORK(OUTNDX)) 00057400 C CALL ARMVE(SPELEV(WRTNDX), DATTR(1), NOPAR) 00057500 CTJT CALL ARMVE(SPELEV(OUTNDX), DATTR(1), NOPAR) 00057600 CTJT CALL FOWP (GM3D, 0, DAP, 104, DENTRY, *1140) 00057700 CTJT CALL ARSET (DATTR(1), 96, 0) 00057800 CTJT 2010 CONTINUE 00057900 C 00058000 C 00058100 CTJT 2020 CALL ARSET (SPELEV(1), MAXRV, 0) 00058200 2020 CONTINUE 00058300 C 00058400 RETURN 00058500 C 00058600 C 00058700 C 00058800 C 00058900 9120 FORMAT(/,' *** ILLEGAL RECEIVER INFORMATION *** ', A80) 00059000 C 00059100 9130 FORMAT(/,' *** INVALID SHOTPOINT NUMBER *** ', A80) 00059200 C 00059300 9140 FORMAT(/,' *** NO INFORMATION ON CARD *** ', A80) 00059400 C 00059500 9150 FORMAT(/,' *** ILLEGAL SHOTPOINT INFORMATION *** ', A80) 00059600 C 00059700 CTJT 9160 FORMAT(/,' *** FOWP HAD A WRITE ERROR DURING SPE WRITE ***') 00059800 C 00059900 9200 FORMAT('1 DATA FROM "XYE" CARDS ',//, 00060000 *25X,'RECEIVER',/, 00060100 * 2X,'RECEIVER',3X,'SHOTPOINT',4X,'STATION',45X,'SHOTPOINT',/, 00060200 * 5X,'NO.',8X,'NO.',8X,'NAME',10X,'X-COORD.',4X,'Y-COORD.', 00060300 * 4X,'ELEVATION',6X,'NAME',10X,'X-COORD.',5X,'Y-COORD.', 00060400 * 4X,'ELEVATION',/, 00060500 * 2X,'********',3X,'*********',3X,'********',8X,'********', 00060600 * 4X,'********',4X,'*********',4X,'*********',7X,'********', 00060700 * 5X,'********',4X,'*********') 00060800 C 00060900 9210 FORMAT(3X,I5,17X,A8,7X,F9.1,3X,F9.1,5X,I6,6X,A8,7X,F9.1, 00061000 * 4X,F9.1,5X,I6) 00061100 C 00061200 9220 FORMAT(14X,I5,6X,A8,7X,F9.1,3X,F9.1,5X,I6,6X,A8,7X,F9.1, 00061300 * 4X,F9.1,5X,I6) 00061400 C 00061500 9230 FORMAT(3X,I5,6X,I5,6X,A8,7X,F9.1,3X,F9.1,5X,I6,6X,A8,7X,F9.1, 00061600 * 4X,F9.1,5X,I6) 00061700 C 00061800 END 00062000