CTITLESAPK28 - 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 = PICKN 00080000 C 00090000 C 00100000 C SUBROUTINE PICKN(OTR,LEN, 00110000 C 00120000 SUBROUTINE SAPK28(OTR,LEN, 00130000 + IPR,NSEF,NSEG,XL,A,B,T4,X1,JSHT,ILCD, 00140000 + DF,DT,YY,YC,T2, 00150000 + WK,TWK, 00160000 + K1,K2,J,KT1, 00170000 + ISHT,IT1, 00180000 + KPBUGF,JSHOT,TOLR2,JERR,TOLR, 00190000 + ITRN, 00200000 + I20,NORTN,AXK21,AXK,KK0, 00210000 + LPOS,JPOS,IT2,T6,NPOS, 00220000 + ILHT,EX,NSHT,MSHT,IRP2,RP1,JM,JJM, 00230000 + I400,CONS,OH,ITHL,PTZ,JPTZ) 00240000 C 00250000 DIMENSION OTR(LEN,1),XL(1),A(1),B(1),T4(1),X1(1), 00260000 + JSHT(I20,I20,1),ILCD(1),YY(I20,I20,1),YC(1),T2(1), 00270000 + WK(I20,1),TWK(I20,1),KT1(1), 00280000 + ISHT(1),IT1(I20,I20,1), 00290000 + LPOS(I20,I20,1),JPOS(1),IT2(I20,1),T6(1),NPOS(1), 00300000 + ILHT(1),EX(1),NSHT(1),MSHT(1),IRP2(1),RP1(1),JM(1), 00310000 + JJM(1),OH(ITHL,1) 00320000 C 00330000 C --------- INITIAL 00340000 C 00350000 JERR=0 00360000 C 00370000 TOL=TOLR2+XL(NSEG) 00380000 TOL8=TOL*8. 00390000 C 00400000 IF(KPBUGF.GT.1) 00410000 +WRITE(IPR,1112)TOLR2,TOL,XL(NSEG),TOL8,TOLR 00420000 1112 FORMAT(1X,18F7.3) 00430000 C 00440000 IK=0 00450000 IJ=1 00460000 MM=I20 00470000 DO 1000 J=K1,K2 00480000 T2(J)=-1. 00490000 IF(ILCD(J).NE.1) GO TO 1000 00500000 C 00510000 T6(J)=TPOS(X1(J),NSEF,XL,NSEG,A,B,K) 00520000 C 00530000 T4(J)=T6(J) 00540000 C 00550000 C CALL PICKP(IPR,T6(J),DF,I20,ITRN,OTR(1,J),LEN,TWK(1,J),WK(1,J), 00560000 CALL SAPK29(IPR,T6(J),DF,I20,ITRN,OTR(1,J),LEN,TWK(1,J),WK(1,J), 00570000 + DT,J,JK,NPOS(J),KPBUGF,1,TOL8,AXK-AXK21*X1(J),JSHOT, 00580000 + CONS,OH(1,J),PTZ,JPTZ) 00590000 C 00600000 C IF(JK.GT.0) CALL PICKR(J,NPOS(J),IK,KT1,MM,IJ) 00610000 IF(JK.GT.0) CALL SAPK31(J,NPOS(J),IK,KT1,MM,IJ) 00620000 C 00630000 1000 CONTINUE 00640000 C 00650000 C 00660000 C ---------- START 00670000 C 00680000 C 00690000 IF(IK.EQ.0) GO TO 1010 00700000 C 00710000 C CALL PICKG(IPR,T6,I20,TWK, 00720000 CALL SAPK21(IPR,T6,I20,TWK, 00730000 + WK,KPBUGF,1, 00740000 + JSHOT,IK,KT1,JSHT,YY,T4,YC, 00750000 + TOLR,IT1,ISHT,NPOS,LPOS,JPOS,CONS,MM,IJ,IT2,T2, 00760000 + ILHT,EX,NSHT,I400,MSHT,IRP2,RP1,JM,JJM) 00770000 C 00780000 IF(IK.GT.0) RETURN 00790000 C 00800000 1010 CONTINUE 00810000 C 00820000 JERR=1 00830000 WRITE(IPR,1005)JSHOT,KK0 00840000 1005 FORMAT(' **** NOTE @@ SAPK28 ****',5X,'NO PICKS MADE AT SHOT (=', 00850000 + I6,' ); SPLIT SIDE (=',I2,' )') 00860000 C 00870000 RETURN 00880000 C 00890000 END 00900000