CTITLESAGCF1 -- READ CFS CARDS FOR SAGM3D 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA AUTHOR K. GRAY 00020000 CA DESIGNER K. GRAY 00030000 CA LANGUAGE FORTRAN 00040000 CA SYSTEM IBM AND CRAY 00050000 CA WRITTEN 08-03-84 00060000 CA REVISED 03-01-85 RDK. DUAL IBM/CRAY VERSION. 00070000 C REVISED 12-28-87 LWC. CHANGED PRINTOUT BY REORDERING 00080000 C COLUMNS BY REQUEST. 00090000 C REVISED 07-11-88 TJT - ADD FILE INCREMENT - HANDLE ODD INCREMENTS00100000 C AND DECREASING FILE NUMBERS. 00110000 C REVISED 01-24-89 TJT - ALLOW MULTIPLE ALP CARDS. 00120000 C REVISED 03-20-89 TJT - SINGLE SOURCE FOR IBM AND CRAY. 00130000 C REVISED 08-28-89 TJT - FIX PROBLEM WITH 2-D DUP. SHOT POINT NO. 00140000 C REVISED 08-16-90 LWC - FIX PROBLEM WITH RECEIVER ADVANCE DELAY. 00150000 C REVISED 09-09-91 ESN - PASS BACK NUMBER OF DUPLICATE SHOT POINTS.00160001 CA 00170000 CA 00180000 CA CALL SAGCF1( STSPNO, SPNIBN, STFILE, ENFILE, FINC, SPADV, RVADV, 00190000 CA * CLD, REFFLG, FSTAN, PERPOS, POSINC, INLNOS, INLINC, INKNTR, 00200000 CA * IPR, SPLSNO, SPAZMF, SPADVI, ODGMSW, NOCCFS, MAXSPS, ASPNO, 00210000 CA * FILENO, DIVOCT, COSFLG, SPAZM, INDEX, FMGSP, MNRV, MAXRVS, 00220000 CA * WORK, CARD, DUPSP, NALP, DUPIND, *STMT ) 00230001 CA 00240000 CA 00250000 CA THIS SUBROUTINE IS CALLED BY SAGM3D TO READ AND PROCESS CFS 00260000 CA CARDS. 00270000 CA 00280000 CA 00290000 CA IN/OUT ARG TYPE LENGTH DESCRIPTION 00300000 CA 00310000 CA IN/OUT STSPNO I*4 1 STARTING SHOTPOINT 00320000 CA IN/OUT SPNIBN I*4 1 SHOTPOINT NUMBER INCREMENT 00330000 CA IN/OUT STFILE I*4 1 STARTING CONSECUTIVE FILE NUMBER 00340000 CA IN/OUT ENFILE I*4 1 ENDING CONSECUTIVE FILE NUMBER 00350000 CA IN FINC I*4 1 FILE NUMBER INCREMENT 00360000 CA IN/OUT SPADV R*4 1 SHOTPOINT ADVANCE 00370000 CA IN/OUT RVADV R*4 1 RECEIVER ADVANCE 00380000 CA IN/OUT CLD I*4 1 NUMERIC ID 00390000 CA IN/OUT REFFLG I*4 1 REC. STN NEAR SHOT FLAG,0=BLANK,1=NO 00400000 CA IN/OUT FSTAN R*4 1 RECEIVER STATION NEAREST SHOT FROM DF6 00410000 CA IN/OUT PERPOS R*4 1 PERPENDICULAR OFFSET 00420000 CA IN/OUT POSINC R*4 1 PERPENDICULAR OFFSET INCREMENT 00430000 CA IN/OUT INLNOS R*4 1 INLINE OFFSET 00440000 CA IN/OUT INLINC R*4 1 INLINE OFFSET INCREMENT 00450000 CA IN/OUT INKNTR R*4 1 RECEIVER ADVANCE DELAY 00460000 CA IN/OUT IPR I*4 1 FORTRAN PRINT UNIT 00470000 CA IN/OUT SPLSNO R*4 MAXSPS ARRAY FOR REC STN NEAREST SHOTPOINT 00480000 CA IN/OUT SPAZMF I*4 1 AZIMUTH FLAG, 1=NON-BLANK 00490000 CA IN/OUT SPADVI R*4 1 SHOTPOINT ADVANCE CONVERTED TO DISTANCE00500000 CA IN/OUT ODGMSW I*4 1 ODD GEOMETRY FLAG, 0=NO, 99999=YES 00510000 CA IN/OUT NOCCFS I*4 1 NUMBER OF CFS CARDS READ 00520000 CA IN/OUT MAXSPS I*4 1 SIZE OF SHOTPOINT ARRAYS ALLOCATED 00530000 CA IN/OUT ASPNO R*4 MAXSPS SHOTPOINT NUMBER ARRAY 00540000 CA IN/OUT FILENO I*4 MAXSPS FILE NUMBER ARRAY 00550000 CA IN DIVOCT I*4 5 OCTAL CONVERSION ARRAY 00560000 CA IN/OUT COSFLG I*4 1 OCTAL FILENUMBER FLAG, 0=NO, 1=YES 00570000 CA IN/OUT SPAZM I*4 1 AZIMUTH FOR THIS SHOTPOINT RANGE 00580000 CA IN/OUT INDEX I*4 1 SHOTPOINT COUNTER AND ARRAY INDEX 00590000 CA IN FMGSP R*4 1 RECEIVER INTERVAL (DISTANCE UNITS) 00600000 CA IN/OUT MNRV I*4 1 RECEIVER CLOSEST TO THE FIRST SHOT 00610000 CA IN/OUT MAXRVS I*4 1 MAXIMUM RECEIVERS ALLOCATED 00620000 CA IN/OUT WORK I*4 MAXRVS WORK ARRAY 00630000 CA IN/OUT CARD I*4 20 CARD BUFFER 00640000 CA IN/OUT DUPSP I*4 MAXSPS*2 CK DUP STPT AND CLD ID 00650000 CA IN/OUT NALP I*4 1 NUMBER OF ALP 00660001 CA IN/OUT DUPIND I*4 1 NUMBER OF TOTAL SP'S (INCL DUPS) 00670005 CA IN/OUT &STMT STATEMENT TO RETURN TO UPON ERROR 00680000 CA 00690000 C EJECT 00700000 C 00710000 SUBROUTINE SAGCF1(STSPNO, SPNIBN, STFILE, ENFILE, FINC, SPADV, 00720000 * RVADV, CLD, REFFLG, FSTAN, PERPOS, POSINC, INLNOS, INLINC, 00730000 * INKNTR, IPR, SPLSNO, SPAZMF, SPADVI, ODGMSW, NOCCFS, MAXSPS, 00740000 * ASPNO, FILENO, DIVOCT, COSFLG, SPAZM, INDEX, FMGSP, MNRV, 00750000 * MAXRVS, WORK, CARD, DUPSP, NALP, DUPIND, * ) 00760001 C 00770000 IMPLICIT INTEGER (A - Z) 00780000 C 00790000 REAL SPADV 00800000 REAL RVADV 00810000 REAL FSTAN 00820000 REAL PERPOS 00830000 REAL POSINC 00840000 REAL INLNOS 00850000 REAL INLINC 00860000 REAL SPADVI 00870000 REAL FMGSP 00880000 C 00890000 INTEGER FILENO (MAXSPS) 00900000 INTEGER ASPNO (MAXSPS) 00910000 INTEGER DUPSP (MAXSPS,2) 00920000 INTEGER WORK (MAXRVS) 00930000 INTEGER DIVOCT ( 5) 00940000 C 00950000 REAL SPLSNO (MAXSPS) 00960000 C 00970000 CHARACTER*80 CARD 00980000 CHARACTER*5 BLNKC 00990000 C 01000000 DATA BLNKC / ' ' / 01010000 C 01020000 CERR = 0 01030000 C 01040000 C STARTING SHOTPOINT NO. 01050000 C 01060000 STSPNO = S1CVBN (CARD, 11, 5) 01070000 LSTSPNO = STSPNO 01080000 COUT IF (S1CPCH (CARD, 11, BLNKC, 1, 5) .NE. 0) GO TO 50 01090000 IF ( CARD(11:15).NE.BLNKC(1:5) ) GO TO 50 01100000 WRITE (IPR, 9010 ) 01110000 CERR = CERR + 1 01120000 C STARTING FILE NO. 01130000 C 01140000 50 STFILE = S1CVBN (CARD, 21, 5) 01150000 COUT IF (S1CPCH (CARD, 21, BLNKC, 1, 5) .NE. 0) GO TO 60 01160000 IF ( CARD(21:25).NE.BLNKC(1:5) ) GO TO 60 01170000 WRITE (IPR, 9020 ) 01180000 CERR = CERR + 1 01190000 C 01200000 60 IF (NOCCFS .GT. 1) GO TO 110 01210000 C SHOTPOINT INCREMENT 01220000 COUT IF (S1CPCH (CARD, 16, BLNKC, 1, 5) .NE. 0) GO TO 70 01230000 IF ( CARD(16:20).NE.BLNKC(1:5) ) GO TO 70 01240000 WRITE (IPR, 9030 ) 01250000 CERR = CERR + 1 01260000 C SHOTPOINT ADVANCE 01270000 C 01280000 COUT0 IF (S1CPCH (CARD, 31, BLNKC, 1, 5) .NE. 0) GO TO 80 01290000 70 IF ( CARD(31:35).NE.BLNKC(1:5) ) GO TO 80 01300000 WRITE (IPR, 9040 ) 01310000 CERR = CERR + 1 01320000 C RECEIVER ADVANCE 01330000 C 01340000 COUT0 IF (S1CPCH (CARD, 36, BLNKC, 1, 5) .NE. 0) GO TO 90 01350000 80 IF ( CARD(36:40).NE.BLNKC(1:5) ) GO TO 90 01360000 WRITE (IPR, 9050 ) 01370000 CERR = CERR + 1 01380000 C NUMERIC ID. 01390000 C 01400000 COUT0 IF (S1CPCH (CARD, 41, BLNKC, 1, 5) .NE. 0) GO TO 100 01410000 90 IF ( CARD(41:45).NE.BLNKC(1:5) ) GO TO 100 01420000 WRITE (IPR, 9060 ) 01430000 CERR = CERR + 1 01440000 C RECEIVER STATION NO. 01450000 C 01460000 100 MNRV = S1CVBN (CARD, 46, 5) 01470000 C 01480000 COUT IF (S1CPCH (CARD, 46, BLNKC, 1, 5) .NE. 0) GO TO 110 01490000 IF ( CARD(46:50).NE.BLNKC(1:5) ) GO TO 110 01500000 WRITE (IPR, 9070 ) 01510000 CERR = CERR + 1 01520000 C TERMINATE IF ERROR HAS BEEN ENCOUNTERED 01530000 C 01540000 110 IF (CERR .EQ. 0) GO TO 120 01550000 GO TO 2840 01560000 C 01570000 120 CONTINUE 01580000 C 01590000 C PROCESS REMAINING 'CFS' CARDS 01600000 C 01610000 COUT IF (S1CPCH (CARD, 16, BLNKC, 1, 5) .NE. 0)SPNIBN = S1CVBN 01620000 IF ( CARD(16:20).NE.BLNKC(1:5) )SPNIBN = S1CVBN 01630000 * (CARD, 16, 5) 01640000 C 01650000 ENFILE = STFILE 01660000 COUT IF (S1CPCH (CARD, 26, BLNKC, 1, 5) .NE. 0)ENFILE = S1CVBN 01670000 IF ( CARD(26:30).NE.BLNKC(1:5) )ENFILE = S1CVBN 01680000 * (CARD, 26, 5) 01690000 C 01700000 COUT IF (S1CPCH (CARD, 31, BLNKC, 1, 5) .NE. 0) 01710000 IF ( CARD(31:35).NE.BLNKC(1:5) ) 01720000 * CALL USCHFT(CARD, 31, 5,SPADV) 01730000 IF (SPADV .LT. 0 .AND. NOCCFS .EQ. 1) ODGMSW = 99999 01740000 C 01750000 COUT IF (S1CPCH (CARD, 36, BLNKC, 1, 5) .NE. 0) 01760000 IF ( CARD(36:40).NE.BLNKC(1:5) ) 01770000 * CALL USCHFT(CARD, 36, 5,RVADV) 01780000 C 01790000 COUT IF (S1CPCH (CARD, 41, BLNKC, 1, 5) .NE. 0)CLD = S1CVBN 01800000 IF ( CARD(41:45).NE.BLNKC(1:5) )CLD = S1CVBN 01810000 *(CARD, 41, 5) 01820000 C 01830000 REFFLG = 0 01840000 COUT IF (S1CPCH (CARD, 46, BLNKC, 1, 5) .NE. 0)REFFLG = 1 01850000 IF ( CARD(46:50).NE.BLNKC(1:5) )REFFLG = 1 01860000 COUT IF (S1CPCH (CARD, 46, BLNKC, 1, 5) .NE. 0)FSTAN = S1CVBN 01870000 IF ( CARD(46:50).NE.BLNKC(1:5) )FSTAN = S1CVBN 01880000 * (CARD, 46, 5) 01890000 C 01900000 COUT IF (S1CPCH (CARD, 51, BLNKC, 1, 5) .NE. 0) 01910000 IF ( CARD(51:55).NE.BLNKC(1:5) ) 01920000 * CALL USCHFT(CARD, 51, 5, PERPOS) 01930000 C 01940000 COUT IF (S1CPCH (CARD, 56, BLNKC, 1, 5) .NE. 0) 01950000 IF ( CARD(56:60).NE.BLNKC(1:5) ) 01960000 * POSINC = S1CVBN (CARD, 56, 5) 01970000 C * CALL USCHFT (CARD, 56, 5, POSINC) 01980000 C 01990000 COUT IF (S1CPCH (CARD, 61, BLNKC, 1, 5) .NE. 0) 02000000 IF ( CARD(61:65).NE.BLNKC(1:5) ) 02010000 * CALL USCHFT (CARD, 61, 5, INLNOS) 02020000 C 02030000 COUT IF (S1CPCH (CARD, 66, BLNKC, 1, 5) .NE. 0) 02040000 IF ( CARD(66:70).NE.BLNKC(1:5) ) 02050000 * INLINC = S1CVBN (CARD, 66, 5) 02060000 C * CALL USCHFT (CARD, 66, 5, INLINC) 02070000 C 02080000 COUT IF (S1CPCH (CARD, 71, BLNKC, 1, 5) .EQ. 0) GO TO 130 02090000 IF ( CARD(71:75).EQ.BLNKC(1:5) ) GO TO 130 02100000 SPAZMF = 1 02110000 SPAZM = S1CVBN (CARD, 71, 5) 02120000 C 02130000 130 INKNTR = 1 02140000 COUT IF (S1CPCH (CARD, 76, BLNKC, 1, 5) .NE. 0)INKNTR = S1CVBN 02150000 IF ( CARD(76:80).NE.BLNKC(1:5) )INKNTR = S1CVBN 02160000 * (CARD, 76, 5) 02170000 C 02180000 C INITIAL PROCESSING OF 'CFS' CARDS 02190000 C 02200000 SPADVI = SPADV * .01 * FMGSP 02210000 SPKNTR = 0 02220000 FINCX = FINC 02230000 IF(STFILE .GT. ENFILE) FINCX = FINCX * (-1) 02240000 C 02250000 DO 180 02260000 * N = STFILE, ENFILE, FINCX 02270000 C TEST FOR OCTAL NUMBERS 02280000 IF (COSFLG .EQ. 0) GO TO 134 02290000 TSTN = N 02300000 DO 133 02310000 * J = 1, 5 02320000 TSTNO = TSTN / DIVOCT(J) 02330000 IF (TSTNO .LE. 7) GO TO 133 02340000 IF ( N.EQ.STFILE .OR. N.EQ.ENFILE) 02350000 * CALL SAGERR (11, CARD, *2840) 02360000 C 02370000 GO TO 180 02380000 133 TSTN = TSTN - DIVOCT(J)*TSTNO 02390000 C 02400000 134 INDEX = INDEX + 1 02410000 TMOD = MOD(SPKNTR, INKNTR) 02420000 IF (TMOD .NE. 0)TMOD = 1 02430000 WORK(INDEX) = INDEX 02440000 IF (INDEX .GT. MAXSPS) 02450000 * CALL SAGERR (8, DUM, *2840) 02460000 C 02470000 IF (N .EQ. STFILE .AND. REFFLG .EQ. 1) GO TO 135 02480000 FSTAN = FSTAN + SPADVI 02490000 C 02500000 135 IF (N .EQ. STFILE) GO TO 140 02510000 PERPOS = PERPOS + POSINC 02520000 INLNOS = INLNOS + INLINC 02530000 STSPNO = STSPNO + TMOD 02540000 IF (TMOD.EQ.0 .AND. INKNTR.EQ.1)STSPNO = STSPNO + SPNIBN 02550000 C 02560000 C IF (TMOD.EQ.0 .AND. INKNTR.GT.1) 02570000 C * STSPNO = STSPNO/SPNIBN*SPNIBN + SPNIBN 02580000 C 02590000 IF (TMOD.EQ.0 .AND. INKNTR.GT.1) THEN 02600000 STSPNO = LSTSPNO + SPNIBN 02610000 LSTSPNO = STSPNO 02620000 ENDIF 02630000 C 02640000 GO TO 150 02650000 C 02660000 C PRINT THE CFS CARD WITH ITS DEFAULTS 02670000 C 02680000 140 IF (NOCCFS .EQ. 1) WRITE (IPR, 9090 ) 02690000 WRITE (IPR, 9100 ) STSPNO, FSTAN, CLD, SPNIBN, 02700000 * STFILE,ENFILE, SPADV, RVADV ,PERPOS, 02710000 * POSINC, INLNOS, INLINC, SPAZM, INKNTR 02720000 C 02730000 C CHECK FOR REPEATING SHOTPOINTS 02740000 C 02750000 150 ISKIP = 0 02760000 IF (INDEX .EQ. 1) GO TO 170 02770000 C 02780000 DO 160 I = 1, DUPIND 02790000 IF (STSPNO .NE. DUPSP(I,1)) GO TO 160 02800000 IF (NALP .LE. 1 ) CALL SAGERR ( 9, STSPNO, *2840) 02810000 IF (CLD .EQ. DUPSP(I,2)) CALL SAGERR ( 9, STSPNO, *2840) 02820000 ISKIP = 1 02830000 160 CONTINUE 02840000 170 IF(ISKIP .EQ. 0) THEN 02850000 FILENO (INDEX) = N 02860000 ASPNO (INDEX) = STSPNO 02870000 SPLSNO (INDEX) = FSTAN 02880000 SPKNTR = SPKNTR + 1 02890000 ELSE 02900000 INDEX = INDEX - 1 02910000 ENDIF 02920000 C 02930000 DUPIND = DUPIND + 1 02940000 DUPSP(DUPIND,1)= STSPNO 02950000 DUPSP(DUPIND,2)= CLD 02960000 C 02970000 180 CONTINUE 02980000 C 02990000 RETURN 03000000 C 03010000 2840 RETURN 1 03020000 C 03030000 C---------------------- FORMATS ----------------------------- 03040000 C 03050000 9010 FORMAT (/,' *** NO STARTING SHOTPOINT ON THIS CFS',/,1X, A80) 03060000 C 03070000 9020 FORMAT (/,' *** NO STARTING FILE FOUND ON THIS CFS',/,1X, A80) 03080000 C 03090000 9030 FORMAT (/,' *** NO SHOTPOINT NO. INC. ON THIS CFS',/,1X, A80) 03100000 C 03110000 9040 FORMAT (/,' *** NO SHOT ADV. FOUND ON THIS CFS',/,1X, A80) 03120000 C 03130000 9050 FORMAT (/,' *** NO RECEIVER ADV. FOUND ON THIS CFS',/,1X, A80) 03140000 C 03150000 9060 FORMAT (/,' *** NO CLD NUMBER FOUND ON THIS CFS',/,1X, A80) 03160000 C 03170000 9070 FORMAT (/,' *** NO RECEIVER STA. (DF13) ON THIS CFS',/,1X, A80) 03180000 C 03190000 9090 FORMAT (' CFS CARDS(3) WITH DEFAULTS:',/, 03200000 *' --------------------------- ',/, 03210000 *' SHOTNO. REFER. CABLE SHOTNO. FILE FILE SHOTPT. ', 03220000 *' RECEIVER PERP. PERP. INLINE INLINE AZIMUTH ', 03230000 *' RECEIVER'/, 03240000 *' START STATION LAYOUT INC. START END ADVANCE ', 03250000 *' ADVANCE OFFSET INC. OFFSET INC. DEGREES ', 03260000 *' ADV.DELAY'/) 03270000 C 03280000 9100 FORMAT (1X,I7,F10.0,I8,I7,I8,I7,2F9.1,1X,2F8.0,F8.2,F8.0,I8,I10) 03290000 C 03300000 END 03310000