CTITLESAGKAR -- SETS TRACE HEADER TICD AND POLARTIY FLAGS 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 00000501 CA WRITTEN 02-23-78 00000600 C REVISED 11-01-79 BY COOPER ADDED 'KBR' AND 'RBR'. 00000700 C REVISED 02-21-80 BY COOPER FIXED KBR AND RBR WHERE ONLY CHECKS 00000800 C IF RECEIVER IN SP FOR BEGINNING AND ENDING 00000900 C OF THE RANGE. 00001000 C REVISED 09-18-80 BY JCR. CORRECTED ERR FOR ZERO SHOTPT. 00001100 C REVISED 05-26-82 BY PKC. CORRECTED ERROR MESSAGE FOR ENDING SHOT 00001200 C NOT FOUND. 00001300 C REVISED 08-06-84 BY RDK. DIMENSION TRCHDR TO 190 WORDS. 00001400 C REVISED 10-23-84 GRAY - CORRECTED VS COMPILE ERRORS. DECLARED 00001500 C TYP, KIL,ETC AS CHARACTER. CORRECTED BRANCH TO 00001600 C THE BOTTOM OF A DO LOOP. 00001700 C REVISED 03-01-85 BY RDK. DUAL IBM/CRAY VERSION. 00001800 C REVISED 02-06-89 BY TJT. ALLOW MULTIPLE ALP CARDS. 00001900 C REVISED 03-20-89 BY TJT. SINGLE SOURCE CODE FOR IBM AND CRAY. 00002001 CA 00002100 CA 00002200 CA CALL SAGKAR 00002300 CA (KPNA,KPRNO,ASPNO,WORK,INDEX,NOREC,LCTPSP,LRTF,NOERR,IPR) 00002400 CA INPUT KPNA = PROCESS NAME A4 00002500 CA INPUT KPRNO = PROCESS NUMBER I4 00002600 CA INPUT ASPNO = SHOTPOINT NO. ARRAY I4 00002700 CA INPUT WORK = WORK ARRAY I4 00002800 CA INPUT INDEX = NO. OF ELEMENTS IN ASPNO I4 00002900 CA INPUT NOREC = NO. OF TRACE HEADERS ON GM3D FILE I4 00003000 CA INPUT LCTPSP = TRACES PER SHOTPOINT I4 00003100 CA INPUT LRFT = ERROR RETURN FLAG (= -1) IF ERROR I4 00003200 CA INPUT NOERR = ERROR COUNTER I4 00003300 CA INPUT IPR = PRINTER UNIT I4 00003400 CA 00003500 CA THIS SUBROUTINE SETS TRACE HEADER TICD AND POLARITY FLAGS 00003600 CA AS SPECIFIED BY INPUT CARDS 'KIL' AND 'REV'. 00003700 C 00003800 SUBROUTINE SAGKAR 00005100 * (KPNA,KPRNO,ASPNO,WORK,INDEX,NOREC,LCTPSP,LRTF,NOERR,IPR) 00005200 C 00005300 IMPLICIT INTEGER (A-Z) 00005400 C 00005500 C INTEGER ARRAYS IN PARAMETER LIST 00005600 C 00005700 INTEGER ASPNO (1) 00005800 INTEGER WORK (1) 00005900 C 00006000 C INTEGER ARRAYS - LOCAL 00006100 C 00006200 INTEGER TRCHDR(190) 00006300 C 00006400 C INTEGER CONSTANTS - LOCAL 00006500 C 00006600 CHARACTER*5 BLANKS 00006700 CHARACTER*80 CARD 00006800 CHARACTER*4 KIL 00006900 CHARACTER*4 REV 00007000 CHARACTER*4 KBR 00007100 CHARACTER*4 RBR 00007200 CHARACTER*4 TYP 00007300 C 00007400 C INITIALIZATION 00007500 C 00007600 DATA BLANKS /' '/ 00007700 DATA KIL /'KIL '/ 00007800 DATA REV /'REV '/ 00007900 DATA KBR /'KBR '/ 00008000 DATA RBR /'RBR '/ 00008100 C 00008200 C INITIALIZE MAXIMUM RECEIVERS 00008300 C 00008400 DA1 = 1 00008500 CALL USRHDR (TRCHDR, DA1, *2830) 00008600 CALL USRTHV (TRCHDR, 'THNGPS ', NGPS) 00008700 CALL USRTHV (TRCHDR, 'THSTGS ', STGS) 00008800 MAXRCV = STGS + NGPS - 1 00008900 C 00009100 C READ 'KIL' AND 'REV' CARDS 00009200 C ========================== 00009300 C 00009400 2250 DO 2430 00009500 * L = 1, 4 00009600 DA1 = 1 00009700 TYP = KIL 00009800 IF (L .EQ. 2) TYP = REV 00009900 IF (L .EQ. 3) TYP = KBR 00010000 IF (L .EQ. 4) TYP = RBR 00010100 NOC = 0 00010200 RNDX = 1 00010300 C 00010400 C SCAN FOR APPROPRIATE CARD 00010500 C 00010600 2260 CALL FORC (KPNA, KPRNO, DA1, CARD, *2310 ) 00010700 C 00011300 COUT IF (S1CPCH(CARD,8, TYP ,1,3) .NE. 0) GO TO 2260 00011400 IF ( CARD(8:10) .NE. TYP(1:3) ) GO TO 2260 00011501 C 00011700 NOC = NOC + 1 00011800 C 00011900 C GET RANGE OFF CARD 00012000 C 00012100 SPS = S1CVBN (CARD,11, 5) 00012200 SPE = S1CVBN (CARD,16,5) 00012300 COUT IF (S1CPCH(CARD,11,' ',1,5) .EQ. 0) GO TO 2790 00012400 COUT IF (S1CPCH(CARD,16,' ',1,5) .EQ. 0) SPE = SPS 00012500 IF ( CARD(11:15) .EQ. BLANKS(1:5) ) GO TO 2790 00012601 IF ( CARD(16:20) .EQ. BLANKS(1:5) ) SPE = SPS 00012701 C 00012800 C TEST FOR VALID RANGE POINTS 00012900 C 00013000 DO 2270 00013100 * I = 1, INDEX 00013200 IF (SPS .NE. ASPNO(I))GO TO 2270 00013300 C 00013400 GO TO 2280 00013500 C 00013600 2270 CONTINUE 00013700 C 00013800 WRITE (IPR, 9140 ) CARD 00013900 NOERR = NOERR + 1 00014000 LRTF = -1 00014100 GO TO 2260 00014200 C 00014300 2280 DO 2290 00014400 * I = 1, INDEX 00014500 IF (SPE .NE. ASPNO(I)) GO TO 2290 00014600 C 00014700 GO TO 2300 00014800 C 00014900 2290 CONTINUE 00015000 C 00015100 WRITE (IPR, 9140 ) CARD 00015200 NOERR = NOERR + 1 00015300 LRTF = -1 00015400 GO TO 2260 00015500 C 00015600 2300 CONTINUE 00015700 C STORE RANGES AND DISK ADDRESS 00015800 WORK(RNDX) = SPS 00015900 WORK(RNDX+1) = SPE 00016000 WORK(RNDX+2) = DA1-1 00016100 RNDX = RNDX + 3 00016200 C 00016300 GO TO 2260 00016400 C 00016500 2310 IF (NOC .EQ. 0) GO TO 2430 00016600 C 00016700 RNDX = RNDX -1 00016800 C 00016900 C UPDATE THE TRACE HEADERS WITH KILLS OR REVERSES 00017000 C 00017100 DA1 = 0 00017200 DASV = 0 00017300 C 00017400 C DO FOR THE TOTAL NUMBER OF SHOTPOINTS 00017500 C 00017600 DO 2420 00017700 * N= 1, NOREC, LCTPSP 00017800 C 00017900 DASSP = N 00018000 CALL USRHDR (TRCHDR, DASSP, *2430) 00018100 CALL USRTHV (TRCHDR, 'THSSP ', SPTST) 00018200 C 00018300 C GET SHOTPOINT RANGE AND DISK ADDRESS OF RANGE 00018400 C 00018600 C--------------------------------------------------------------------- 00018701 CKG DO 2320 00018800 CKG * K = 1 , RNDX, 3 00018900 C--------------------------------------------------------------------- 00019001 C 00019101 K = -2 00019200 2319 K = K + 3 00019400 C 00019500 SPS = WORK(K) 00019600 SPE = WORK(K+1) 00019700 DA1 = WORK(K+2) 00019800 C 00019900 IF (SPS .LE. SPTST .AND. SPTST .LE. SPE) GO TO 2330 00020000 IF (SPS .GE. SPTST .AND. SPTST .GE. SPE) GO TO 2330 00020200 C 00020400 2320 IF (K+3.LT.RNDX) GO TO 2319 00020500 C 00020600 GO TO 2420 00020700 C 00020800 C CHECK TYPE BEING IMPLEMENTED 00020900 C 00021000 2330 IF (L .EQ. 3 .OR. L .EQ. 4) GO TO 2411 00021100 IF (DA1 .EQ. DASV) GO TO 2340 00021200 DASV = DA1 00021300 CALL FORC (KPNA, KPRNO, DA1, CARD, *2420 ) 00021400 C 00021501 2340 CONTINUE 00022200 C 00022300 C VALIDATE TRACE RANGES 00022400 C 00022500 DO 2410 00022600 * I = 21, 80, 5 00022700 TRCNS = S1CVBN (CARD,I,5) 00022800 IF (TRCNS .LT. -LCTPSP .OR. TRCNS .GT.LCTPSP) 00022900 * GO TO 2380 00023000 IF (I .EQ. 21. AND. TRCNS .LT. 0) GO TO 2390 00023100 IF (TRCNS .LE. 0) GO TO 2410 00023200 IF (I .EQ. 76) GO TO 2350 00023300 TRCNE = S1CVBN (CARD, I+5, 5) 00023400 IF (TRCNE .LT. -LCTPSP. OR. TRCNE .GT.LCTPSP) 00023500 * GO TO 2380 00023600 IF (TRCNE .GE.0)GO TO 2350 00023700 TRCNE = - TRCNE 00023800 GO TO 2360 00023900 C 00024000 2350 TRCNE = TRCNS 00024100 C 00024200 2360 CONTINUE 00024300 C 00024400 C GET TRACES TO KILL 00024500 C 00024600 DO 2370 00024700 * J = TRCNS, TRCNE 00024800 C 00024900 DA2 = N - 1 + J 00025000 DA3 = DA2 00025100 CALL USRHDR (TRCHDR, DA2, *2830 ) 00025200 C 00025300 IF (TYP .EQ. KIL)CALL USSTHV (TRCHDR, 'THTICD ',2) 00025401 IF (TYP .EQ. REV)CALL USSTHV (TRCHDR, 'THPOL ',2) 00025700 CALL USWHDR (TRCHDR, DA3, *2810 ) 00026000 C 00026100 2370 CONTINUE 00026200 C 00026300 GO TO 2410 00026400 C 00026500 2380 WRITE (IPR, 9150 ) CARD 00026600 GO TO 2400 00026700 C 00026800 2390 WRITE (IPR, 9160 ) CARD 00026900 C 00027000 2400 LRTF = -1 00027100 NOERR = NOERR + 1 00027200 C 00027300 2410 CONTINUE 00027400 C 00027500 GO TO 2320 00027600 C 00027700 C KILL OR REVERSE BY RECEIVER GROUP 00027800 C 00027900 2411 IF (DA1 .EQ. DASV) GO TO 24160 00028000 DASV = DA1 00028100 CALL FORC (KPNA, KPRNO, DA1, CARD, *2420) 00028200 C 00028300 RCVNDX = RNDX + 1 00028900 STINDX = RNDX + 1 00029000 C 00029100 C STORE RECEIVERS TO KILL OR REVERSE IN WORK ARRAY 00029200 C 00029300 DO 2417 00029400 * I = 21, 80, 5 00029500 RCVRS = S1CVBN (CARD, I, 5) 00029600 IF (RCVRS .LT. -MAXRCV .OR. 00029700 * RCVRS .GT. MAXRCV) GO TO 2414 00029800 IF (I .EQ. 21 .AND. RCVRS .LT. 0) GO TO 2415 00029900 IF (RCVRS .LE. 0) GO TO 2417 00030000 IF (I .EQ. 76) GO TO 2412 00030100 RCVRE = S1CVBN(CARD, I+5, 5) 00030200 IF (RCVRE .LT. -MAXRCV .OR. 00030300 * RCVRE .GT. MAXRCV) GO TO 2414 00030400 IF (RCVRE .GE. 0) GO TO 2412 00030500 RCVRE = - RCVRE 00030600 GO TO 2413 00030700 2412 RCVRE = RCVRS 00030800 2413 CONTINUE 00030900 C 00031000 WORK(RCVNDX) = RCVRS * 100 00031100 WORK(RCVNDX+1) = RCVRE * 100 00031200 RCVNDX = RCVNDX + 2 00031300 GO TO 2417 00031400 C 00031500 C WRITE MESSAGE IF ILLEGAL RECEIVER NUMBER 00031600 C 00031700 2414 WRITE (IPR, 9170) CARD 00031800 GO TO 2416 00031900 C 00032000 C WRITE MESSAGE IF FIRST RECEIVER NEGATIVE 00032100 C 00032200 2415 WRITE (IPR, 9180) CARD 00032300 C 00032400 C UPDATE ERROR NUMBER AND RETURN FLAG 00032500 C 00032600 2416 LRTF = -1 00032700 NOERR = NOERR + 1 00032800 2417 CONTINUE 00032900 C 00033000 C SET END POINTER 00033100 C 00033200 RCVNDX = RCVNDX - 1 00033300 24160 FOUND = 0 00033400 C 00033500 C FIND RECEIVERS TO KILL OR REVERSE 00033600 C 00033700 DO 24190 00033800 * J = 1, LCTPSP 00033900 DA2 = N - 1 + J 00034000 DA3 = DA2 00034100 CALL USRHDR (TRCHDR, DA2, *2830) 00034200 CALL USRTHV (TRCHDR, 'THRCLN ', RCLN) 00034300 C 00034400 DO 24170 00034500 * M = STINDX, RCVNDX, 2 00034600 RCVRS = WORK(M) 00034700 RCVRE = WORK(M+1) 00034800 IF (RCVRS .LE. RCLN .AND. 00034900 * RCLN .LE. RCVRE) GO TO 24180 00035000 IF (RCVRS .GE. RCLN .AND. 00035100 * RCLN .GE. RCVRE) GO TO 24180 00035200 24170 CONTINUE 00035300 C 00035400 GO TO 24190 00035500 C 00035600 24180 IF (TYP .EQ. KBR) CALL USSTHV(TRCHDR,'THTICD ',2) 00035700 IF (TYP .EQ. RBR) CALL USSTHV(TRCHDR,'THPOL ',2) 00035800 CALL USWHDR (TRCHDR, DA3, *2810) 00035900 FOUND = 1 00036000 24190 CONTINUE 00036100 C 00036200 C CHECK IF RECEIVER FOUND 00036300 C 00036400 IF (SPTST .NE. SPS .AND. SPTST .NE. SPE) GO TO 2320 00036500 IF (FOUND .EQ. 1) GO TO 2320 00036600 WRITE (IPR, 9200) SPTST, CARD 00036700 WRITE (6 , 9200) SPTST, CARD 00036800 LRTF = -1 00036900 NOERR = NOERR + 1 00037000 WORK(K) = -WORK(K) 00037100 WORK(K+1) = -WORK(K+1) 00037200 C 00037300 C GO BACK AND CHECK IF THIS SHOTPOINT IN 00037400 C ANOTHER RANGE 00037500 C 00037600 GO TO 2320 00037700 C 00037800 2420 CONTINUE 00037900 C 00038000 2430 CONTINUE 00038100 C 00038200 GO TO 2900 00038300 C 00038400 C PRINT ERROR MESSAGES 00038500 C 00038600 2790 WRITE (IPR, 9380) CARD 00038700 GO TO 2900 00038800 C 00038900 2810 WRITE (IPR, 9400) DA3 00039000 GO TO 2900 00039100 C 00039200 2830 WRITE (IPR, 9410) DA3 00039300 C 00039401 2900 RETURN 00039501 C 00039600 C ****** FORMATS ****** 00039701 C 00039900 9140 FORMAT (/,' *** INVALID SHOTPT.NO ***', A80 ) 00040000 C 00040100 9150 FORMAT (/,' *** ILLEGAL TRACE NUMBER ***', A80 ) 00040200 C 00040300 9160 FORMAT (/,' *** FIRST TRACE CAN NOT BE NEG. ***', A80 ) 00040400 C 00040500 9170 FORMAT (/,' *** ILLEGAL RECEIVER NUMBER ***', A80 ) 00040600 C 00040700 9180 FORMAT (/,' *** FIRST RECEIVER CAN NOT BE NEG. ***', A80 ) 00040800 C 00040900 9200 FORMAT (/,' *** SHOTPOINT',I5,' DOES NOT CONTAIN A RECEIVER ', 00041000 * 'LISTED ON THE CARD ***',/5X, A80) 00041100 C 00041200 9380 FORMAT (/,' *** MISSING SHOTNO. ***', A80) 00041300 C 00041400 9400 FORMAT (/,' *** USWHDR HAD ERROR DA = ', I5) 00041500 C 00041600 9410 FORMAT (/,' *** USRHDR HAD ERROR DA = ', I5) 00041700 C 00041800 END 00041900