CTITLESAGRXY -- READ 'XYR' AND/OR 'XYS' CARDS FOR 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 00000601 CA WRITTEN 10/27/77 00000800 C REVISED 08/17/80 P. COOPER - REMOVED CODE FROM SPGM3D. 00000900 C REVISED 11/14/84 K. GRAY - CHANGED FLOATN FROM R*4 TO R*8 00001000 C TO PREVENT LOSS OF ACCURACY. 00001100 C CORRECTED VS FORTRAN COMPILE ERRORS. 00001200 C REVISED 03/04/85 R. KNIGHT - DUAL IBM/CRAY VERSION. 00001300 C REVISED 03/20/89 TJT - SINGLE SOURCE CODE FOR IBM AND CRAY. 00001401 C REVISED 11/13/89 RDK - FOR CRAY CFT77 COMPATIBILITY. 00001502 CA 00001600 CA 00001700 CA CALL SAGRXY (KPNA, KPRNO, IPR, ERR, NOCXYR, NOCXYS, BLNKC, CARD, 00001800 CA * MNRVI, MNRV, RVX, RVY, RVLSNO, RVMNDX, RVNRVS, 00001900 CA * SPX, SPY, WORK, SPMNDX, SPMXDX, INDEX, ASPNO) 00002000 CA 00002100 CA IN/OUT ARGUMENT TYPE DESCRIPTION 00002200 CA 00002300 CA IN KPNA A4 PROCESS NAME 00002400 CA IN KPRNO I4 PROCESS NO. 00002500 CA IN IPR I4 PRINTER UNIT NO. 00002600 CA IN/OUT ERR I4 ERROR INDICATOR 00002700 CA IN/OUT NOCXYR I4 NUMBER OF XYR CARDS READ 00002800 CA IN/OUT NOCXYS I4 NUMBER OF XYS CARDS READ 00002900 CA IN BLNKC A4 BLANK CARD IMAGE 00003000 CA IN CARD A4 CARD IMAGE WORK AREA ARRAY 00003100 CA IN MNRVI I4 MINIMUM RECEIVER BASE INDEX 00003200 CA IN MNRV I4 MINIMUM RECEIVER 00003300 CA IN/OUT RVX R8 RECEIVER STATION X-COOR 00003400 CA IN/OUT RVY R8 RECEIVER STATION Y-COOR 00003500 CA IN/OUT RVLSNO R4 RECEIVER STATION LINE NO. 00003600 CA IN/OUT RVMNDX I4 RECEIVER MINIMUM INDEX 00003700 CA IN/OUT RVNRVS I4 RECEIVER NUMBER OF RECEIVERS 00003800 CA IN/OUT SPX R8 SHOTPOINT X-COOR. 00003900 CA IN/OUT SPY R8 SHOTPOINT Y-COOR. 00004000 CA IN/OUT WORK I4 SHOTPOINT INDEX ARRAY 00004100 CA IN/OUT SPMNDX I4 SHOTPOINT MINIMUM INDEX FOUND 00004200 CA IN/OUT SPMXDX I4 SHOTPOINT MAXIMUM INDEX FOUND 00004300 CA IN/OUT INDEX I4 SHOTPOINT MAXIMUM INDEX 00004400 CA IN ASPNO I4 SHOTPOINT NUMBER ARRAY 00004500 CA 00004600 CA 00004700 CA SAGRXY IS CALLED BY PREPARATION ROUTINE 'GM3D' TO READ AND 00004800 CA THE 'XYR' AND 'XYS' CARDS. THESE CARDS GIVE RECEIVER AND 00004900 CA SHOTPOINT X-Y COORDINATES. 00005000 C EJECT 00005101 C 00005201 SUBROUTINE SAGRXY (KPNA, KPRNO, IPR, ERR, NOCXYR, NOCXYS, BLNKC, 00005900 * CARD, MNRVI, MNRV, RVX, RVY, RVLSNO, RVMNDX, RVNRVS, 00006000 * SPX, SPY, WORK, SPMNDX, SPMXDX, INDEX, ASPNO) 00006100 C 00006300 IMPLICIT INTEGER (A-Z) 00006400 C EXTERNAL S1ATP 00006501 C 00006600 C REAL ARRAYS IN PARAMETER LIST. 00006701 C 00006800 REAL RVLSNO(1) 00006901 C 00007000 DOUBLE PRECISION RVX (1) 00007100 DOUBLE PRECISION RVY (1) 00007200 DOUBLE PRECISION SPX (1) 00007300 DOUBLE PRECISION SPY (1) 00007400 C 00007500 C CHARACTER ARRAYS IN PARAMETER LIST. 00007600 C 00007700 CHARACTER*80 BLNKC 00007801 CHARACTER*80 CARD 00007901 C 00008000 C CHARACTER ARRAYS IN PROGRAM. 00008100 C 00008200 CHARACTER*4 XYR 00008301 CHARACTER*4 XYS 00008401 C 00008500 C INTEGER ARRAYS IN PARAMETER LIST. 00008601 C 00008700 INTEGER WORK (1) 00008801 INTEGER ASPNO (1) 00008901 C 00009100 C REAL VARIABLES AND CONSTANTS 00009201 C 00009300 DOUBLE PRECISION FLOATN 00009400 C 00009500 C INITIALIZATION 00009601 C 00009700 DATA XYR /'XYR '/ 00009801 DATA XYS /'XYS '/ 00009901 C 00010000 C INITIALIZATION AREA 00010101 C 00010200 IF (1.EQ.2) CALL S1ATP 00010301 C 00010401 DA1 = 1 00010500 LERR = ERR 00010600 C 00010700 C READ 'XYR' CARD (6) 00010801 C 00010900 280 CALL FORC (KPNA, KPRNO, DA1, CARD, *310 ) 00011000 C 00011100 COUT IF (S1CPCH (CARD, 8, 'XYR', 1, 3) .NE. 0) GO TO 280 00011200 COUT IF (S1CPCH (CARD, 11, BLNKC, 1, 5) .EQ. 0) GO TO 300 00011300 IF ( CARD(8:10) .NE. XYR(1:3) ) GO TO 280 00011401 IF ( CARD(11:15) .EQ. BLNKC(1:5) ) GO TO 300 00011501 NOCXYR = NOCXYR + 1 00011600 SRVNO = S1CVBN (CARD, 11, 5) 00011700 RVINC = 1 00011800 C 00011900 COUT IF (S1CPCH (CARD, 16, BLNKC, 1, 5) .NE. 0)RVINC = S1CVBN 00012000 IF ( CARD(16:20) .NE. BLNKC(1:5) )RVINC = S1CVBN 00012101 * (CARD, 16, 5) 00012200 C 00012300 INDX = SRVNO - MNRV + MNRVI 00012400 C 00012500 C STORE THE RECEIVER X,Y FROM CARD(6) 00012600 C 00012700 DO 290 00012800 * I = 21, 80, 20 00012900 C 00013000 COUT IF (S1CPCH (CARD, I, BLNKC, 1, 10) .EQ. 0) GO TO 290 00013100 COUT IF (S1CPCH (CARD, I+10, BLNKC, 1, 10) .EQ. 0) GO TO 290 00013200 IF ( CARD(I:I+9) .EQ. BLNKC(1:10) ) GO TO 290 00013301 IF ( CARD(I+10:I+19) .EQ. BLNKC(1:10) ) GO TO 290 00013401 C 00013500 FLOATN = S1CVBN (CARD, I, 10) 00013600 C 00013700 COUT IF (S1CPCH(CARD,I+9,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00013800 IF ( CARD(I+9:I+9) .EQ. BLNKC(1:1) ) FLOATN = FLOATN * 10. 00013901 RVX (INDX) = FLOATN / 10. 00014000 FLOATN = S1CVBN (CARD, I+10, 10) 00014100 COUT IF (S1CPCH(CARD,I+19,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00014200 IF ( CARD(I+19:I+19) .EQ. BLNKC(1:1) ) FLOATN = FLOATN * 10. 00014301 RVY (INDX) = FLOATN / 10. 00014400 RVLSNO (INDX) = SRVNO 00014500 SRVNO = SRVNO + RVINC 00014600 IF (INDX .LT. RVMNDX) RVMNDX = INDX 00014700 IF (INDX .GT. RVNRVS) RVNRVS = INDX 00014800 INDX = INDX + RVINC 00014900 C 00015000 290 CONTINUE 00015100 C 00015200 GO TO 280 00015300 C 00015400 300 WRITE (IPR, 9140 ) CARD 00015500 LERR = LERR + 1 00015600 GO TO 280 00015700 C 00015800 310 CONTINUE 00015900 C 00016000 C INITITALIZATION FOR 'XYS' READ 00016100 C 00016200 DA1 = 1 00016300 C 00016400 C READ 'XYS' CARD (7) 00016500 C 00016600 550 CALL FORC (KPNA, KPRNO, DA1, CARD, *610 ) 00016700 C 00016800 COUT IF (S1CPCH (CARD, 8, 'XYS', 1, 3) .NE. 0) GO TO 550 00016900 COUT IF (S1CPCH (CARD, 11, BLNKC, 1, 5) .EQ. 0) GO TO 600 00017000 IF ( CARD(8:10) .NE. XYS(1:3) ) GO TO 550 00017101 IF ( CARD(11:15) .EQ. BLNKC(1:5) ) GO TO 600 00017201 NOCXYS = NOCXYS + 1 00017300 SPNO = S1CVBN (CARD, 11, 5) 00017400 SPINC = 1 00017500 C 00017600 COUT IF (S1CPCH (CARD, 16, BLNKC, 1, 5) .NE. 0)SPINC = S1CVBN 00017700 IF ( CARD(16:20) .NE. BLNKC(1:5) )SPINC = S1CVBN 00017801 * (CARD, 16, 5) 00017900 C 00018100 C STORE THE SHOTPOINT X,Y FROM CARD(7) 00018200 C 00018300 DO 590 00018400 * I = 21, 80, 20 00018500 C 00018600 COUT IF (S1CPCH (CARD, I, BLNKC, 1, 10) .EQ. 0) GO TO 590 00018700 COUT IF (S1CPCH (CARD, I+10, BLNKC, 1, 10) .EQ. 0) GO TO 590 00018800 IF ( CARD(I:I+9) .EQ. BLNKC(1:10) ) GO TO 590 00018901 IF ( CARD(I+10:I+19) .EQ. BLNKC(1:10) ) GO TO 590 00019001 C 00019100 C FIND THE SHOTPOINT INDEX 00019200 C 00019300 DO 560 00019400 * J = 1, INDEX 00019500 IF (SPNO .EQ. ASPNO(J)) GO TO 570 00019600 C 00019700 560 CONTINUE 00019800 C 00019900 LERR = LERR + 1 00020000 WRITE (IPR, 9150 ) CARD 00020100 C 00020200 GO TO 590 00020300 C 00020400 570 INDX = WORK(J) 00020500 C 00020600 WORK(J) = - WORK(J) 00020700 FLOATN = S1CVBN (CARD, I, 10) 00020800 COUT IF (S1CPCH(CARD,I+9,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00020901 IF ( CARD(I+9:I+9) .EQ. BLNKC(1:1) ) FLOATN = FLOATN * 10. 00021001 SPX (INDX) = FLOATN / 10. 00021100 FLOATN = S1CVBN (CARD, I+10, 10) 00021200 COUT IF (S1CPCH(CARD,I+19,BLNKC,1,1) .EQ. 0) FLOATN = FLOATN * 10. 00021300 IF ( CARD(I+19:I+19) .EQ. BLNKC(1:1) ) FLOATN = FLOATN * 10. 00021401 SPY (INDX) = FLOATN / 10. 00021500 SPNO = SPNO + SPINC 00021700 IF (J .GT. SPMXDX) SPMXDX = J 00021800 IF (J .LT. SPMNDX) SPMNDX = J 00021900 C 00022000 590 CONTINUE 00022100 C 00022200 GO TO 550 00022300 C 00022400 600 WRITE (IPR, 9140 ) CARD 00022500 LERR = LERR + 1 00022600 GO TO 550 00022700 C 00022800 610 CONTINUE 00022900 ERR = LERR 00023000 RETURN 00023100 C 00023200 9140 FORMAT (/,' *** DF6 IS REQUIRED',/,1X, A80) 00023300 C 00023400 9150 FORMAT (/,' *** INVALID SHOTPT. NO. ***', A80) 00023500 C 00023600 END 00023700