CTITLESAPK29 - SUBROUTINE USED BY SDPICK 00010000 C*********************************************************************** C COPYRIGHT ATLANTIC RICHFIELD COMPANY 1991 * C*********************************************************************** CA 00020000 CA DESIGNER P. C. LUH 00030000 CA AUTHOR P. C. LUH 00040000 CA LANGUAGE FORTRAN 00050000 CA SYSTEM IBM ONLY 00060000 CA DATE MM/DD/YY 00070000 C REVISED 03/06/86 LBL OLD NAME = PICKP 00080000 C 00090000 C 00100000 C SUBROUTINE PICKP(IPR,T2,DF,I20,ITRN,OTR,LEN,TWK,WK,DT,J,L,II, 00110000 C 00120000 SUBROUTINE SAPK29(IPR,T2,DF,I20,ITRN,OTR,LEN,TWK,WK,DT,J,L,II, 00130000 + KPBUGF,KP,TOL8,AXK,JSHOT,CONS,OH,PTZ,JPTZ) 00140000 C 00150000 LOGICAL JPTZ 00160000 C 00170000 DIMENSION OTR(1),TWK(1),WK(1),OH(1) 00180000 C 00190000 L=-1 00200000 K3=T2*DF+1.5 00210000 LEK=AMIN1(0.2,TOL8*0.5)*DF 00220000 IPOS=MAX0(1,K3-LEK) 00230000 LPOS=MAX0(1,IPOS-ITRN) 00240000 SUMR=0. 00250000 DO 266 I=LPOS,IPOS 00260000 266 SUMR=SUMR+ABS(OTR(I)) 00270000 IF(SUMR.GT.0.) GO TO 260 00280000 CALL USRTHV(OH,'THFLV ',II) 00290000 XH=(II-1)*DT 00300000 WRITE(IPR,261)JSHOT,J,XH,T2 00310000 261 FORMAT(' ***** WARNING ***** SHOT =',I5,' TRACE =',I5,5X, 00320000 + 'FIRST LIVE SAMPLE (@',F6.3,' )', 00330000 + ' IS TOO CLOSE TO EXPECTED FIRST ARRIVAL (@',F6.3,' )') 00340000 RETURN 00350000 C 00360000 260 CONTINUE 00370000 II=0 00380000 IX=IPOS+1 00390000 IPOS=MIN0(LEN,IPOS+LEK*2) 00400000 L=0 00410000 XH=0. 00420000 C 00430000 IF(PTZ.GT.0.) THEN 00440000 DO 262 I=IX,IPOS 00450000 IF(OTR(I).LE.0.) GO TO 262 00460000 IF(OTR(I).LE.OTR(I-1).OR.OTR(I).LT.OTR(I+1)) GO TO 262 00470000 II=II+1 00480000 TWK(II)=(I-0.5*(OTR(I+1)-OTR(I-1))/(OTR(I+1)+OTR(I-1)-2.*OTR(I)) 00490000 + -1)*DT 00500000 WK(II)=OTR(I)*(I-LPOS)/SUMR 00510000 XH=AMAX1(XH,WK(II)) 00520000 IF(II.LT.I20) GO TO 262 00530000 WRITE(IPR,264)JSHOT,J,I20 00540000 GO TO 265 00550000 262 SUMR=SUMR+ABS(OTR(I)) 00560000 C 00570000 ELSE 00580000 DO 267 I=IX,IPOS 00590000 IF(OTR(I).GE.0.) GO TO 267 00600000 IF(OTR(I).GE.OTR(I-1).OR.OTR(I).GT.OTR(I+1)) GO TO 267 00610000 II=II+1 00620000 TWK(II)=(I-0.5*(OTR(I+1)-OTR(I-1))/(OTR(I+1)+OTR(I-1)-2.*OTR(I)) 00630000 + -1)*DT 00640000 WK(II)=-OTR(I)*(I-LPOS)/SUMR 00650000 XH=AMAX1(XH,WK(II)) 00660000 IF(II.LT.I20) GO TO 267 00670000 WRITE(IPR,264)JSHOT,J,I20 00680000 264 FORMAT(' ***** WARNING *****',5X,'SHOT =',I5,5X,'TRACE =',I5,5X, 00690000 + 'NUMBER OF PEAKS EXCEEDED',I5) 00700000 GO TO 265 00710000 267 SUMR=SUMR+ABS(OTR(I)) 00720000 ENDIF 00730000 C 00740000 265 CONTINUE 00750000 XH=XH*AXK 00760000 XG=0. 00770000 XI=CONS 00780000 DO 269 I=1,II 00790000 IF(WK(I)*(TOL8-ABS(T2-TWK(I))).LT.XG) GO TO 269 00800000 IF(ABS(T2-TWK(I)).GT.XI.OR.WK(I).LT.XH) GO TO 269 00810000 XI=ABS(T2-TWK(I)) 00820000 L=I 00830000 XG=WK(I)*(TOL8-XI) 00840000 269 CONTINUE 00850000 C 00860000 IF(JPTZ) GO TO 263 00870000 C 00880000 I=0 00890000 270 I=I+1 00900000 271 IF(I.GT.II) GO TO 280 00910000 IX=TWK(I)*DF+1.5 00920000 272 IF(IX.GE.LPOS) GO TO 274 00930000 IX=I+1 00940000 DO 273 K3=IX,II 00950000 TWK(K3-1)=TWK(K3) 00960000 WK(K3-1)=WK(K3) 00970000 273 CONTINUE 00980000 C IF(L.EQ.I) 'LET GO' 00990000 IF(L.GT.I) L=L-1 01000000 II=II-1 01010000 GO TO 271 01020000 274 IF(OTR(IX)*OTR(IX-1).LE.0.) GO TO 275 01030000 IX=IX-1 01040000 GO TO 272 01050000 275 TWK(I)=(IX-2-OTR(IX-1)/(OTR(IX)-OTR(IX-1)))*DT 01060000 GO TO 270 01070000 C 01080000 280 CONTINUE 01090000 I=1 01100000 XI=TWK(1) 01110000 281 I=I+1 01120000 282 IF(I.GT.II) GO TO 263 01130000 IF(XI.NE.TWK(I)) GO TO 284 01140000 WK(I-1)=AMAX1(WK(I),WK(I-1)) 01150000 IX=I+1 01160000 DO 283 K3=IX,II 01170000 TWK(K3-1)=TWK(K3) 01180000 WK(K3-1)=WK(K3) 01190000 283 CONTINUE 01200000 IF(L.GE.I) L=L-1 01210000 II=II-1 01220000 GO TO 282 01230000 284 XI=TWK(I) 01240000 GO TO 281 01250000 C 01260000 263 CONTINUE 01270000 IF(KPBUGF.GT.KP) 01280000 +WRITE(IPR,268)JSHOT,J,L,T2,TWK(L),(TWK(I),WK(I),I=1,II) 01290000 268 FORMAT(1X,I8,2I5,2F7.3,2X,8('|',F6.3,F5.1)/(35X,8('|',F6.3,F5.1)))01300000 C 01310000 IF(L.GT.0) T2=TWK(L) 01320000 C 01330000 RETURN 01340000 C 01350000 END 01360000