CTITLESAPK20 - 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 = PICKE 00080000 C REVISED 04/09/87 ESN REPLACE AFFT42 WITH MFORSP. 00090001 C 00100000 C 00110000 C SUBROUTINE PICKE(OTR,LEN, 00120000 C 00130000 SUBROUTINE SAPK20(OTR,LEN, 00140000 + IPR,NSEF,NSEG,XL,A,B,T4,X1,JSHT,ILCD,KTR, 00150000 + DF,MST,MSH,DT,ITRH,YY,YC,T2, 00160000 + WK,IWK, 00170000 + IFIRST,K1,K2,KT1, 00180000 + LEM,AEM, 00190000 + ISHT,IT1, 00200000 + KPBUGF,JSHOT,TOLR2,IERR,TOLR, 00210000 + JFIRST,ITRN, 00220000 + I20,NORTN,AXK21,AXK,KK0, 00230000 + LPOS,JPOS,IT2,T6,NPOS, 00240000 + ILHT,EX,NSHT,MSHT,IRP2,RP1,JM,JJM, 00250000 + I400,CONS,OH,ITHL,PTZ,JPTZ) 00260000 C 00270000 DIMENSION OTR(LEN,1),XL(1),A(1),B(1),T4(1),X1(1), 00280000 + JSHT(1),ILCD(1),KTR(1),YY(1),YC(1),T2(1), 00290000 + WK(1),IWK(1),KT1(1), 00300000 + ISHT(1),IT1(1), 00310000 + LPOS(1),JPOS(1),IT2(1),T6(1),NPOS(1), 00320000 + NSHT(1),ILHT(1),EX(1),MSHT(1),IRP2(1),RP1(1),JM(1), 00330000 + JJM(1),OH(1) 00340000 C 00350000 C CALL PICKK(JSHOT,X1,K1,K2,KPBUGF,ILCD,L,KTR,MST,IPR,IERR, 00360000 CALL SAPK25(JSHOT,X1,K1,K2,KPBUGF,ILCD,L,KTR,MST,IPR,IERR, 00370000 + IFIRST,KK0,CONS,JFIRST) 00380000 C 00390000 IF(JFIRST.NE.0) GO TO 300 00400000 C 00410000 IF(IERR.NE.0) RETURN 00420000 C 00430000 KK=1 00440000 IS=2 00450000 160 IF(IS.GE.LEM) GO TO 170 00460000 KK=KK+1 00470000 IS=IS*2 00480000 GO TO 160 00490000 170 CONTINUE 00500000 K=MIN0(IS/2,INT(100*IS*DT)) 00510000 IF(KPBUGF.GT.1) 00520000 +WRITE(IPR,*)KK,IS,LEM,K 00530000 C 00540000 DO 210 I=1,L 00550000 J=KTR(I) 00560000 IPOS=MAX0(1,KPOS(X1(J),NSEF,XL,NSEG,A,B,DF,LEN,M)-ITRH) 00570000 C 00580000 C CALL STZ(WK,IS*2) 00590000 CALL ARSET(WK,IS*2,0.) 00600000 CALL ARMVE(OTR(IPOS,J),WK,LEM) 00610000 C CALL AFFT42(KK,WK,WK(IS+1),-1) 00620001 CALL MFORSP(KK,WK,WK(IS+1),-1) 00630001 C 00640000 DO 180 M=1,K 00650000 180 WK(M)=WK(M)*WK(M)+WK(IS+M)*WK(IS+M) 00660000 C 00670000 190 FORMAT(1X,I5/(1X,13G10.4)) 00680000 C CALL RNGMED(K,WK,MST,WK(K+1),WK(K+1+MST),WK(K+1+MST*2),MSH, 00690000 CALL SAPK39(K,WK,MST,WK(K+1),WK(K+1+MST),WK(K+1+MST*2),MSH, 00700000 + WK(K+1+MST*3),0) 00710000 C 00720000 XG=0. 00730000 DO 200 M=2,K 00740000 IF(WK(M).LT.WK(M-1).OR.WK(M).LT.WK(M+1)) GO TO 200 00750000 IF(XG.GT.WK(M)) GO TO 200 00760000 N=M 00770000 XG=WK(M) 00780000 200 CONTINUE 00790000 IF(XG.EQ.0.) N=33.3333*DT*IS 00800000 C 00810000 XG=N 00820000 XG=IS/XG 00830000 IF(KPBUGF.GT.1) 00840000 +WRITE(IPR,*)N,IS,XG 00850000 YY(I)=XG 00860000 210 CONTINUE 00870000 C 00880000 C CALL DMED(L,YY,XG,AEM) 00890000 CALL SAPK02(L,YY,XG,AEM) 00900000 AEM=0.5*(XG+AEM) 00910000 C 00920000 IF(KPBUGF.GT.1) 00930000 +WRITE(IPR,*)AEM 00940000 C 00950000 RETURN 00960000 C 00970000 300 CONTINUE 00980000 C 00990000 IF(IERR.NE.0) RETURN 01000000 C 01010000 C CALL PICKN(OTR,LEN, 01020000 CALL SAPK28(OTR,LEN, 01030000 + IPR,NSEF,NSEG,XL,A,B,T4,X1,JSHT,ILCD, 01040000 + DF,DT,YY,YC,T2, 01050000 + WK,IWK, 01060000 + K1,K2,J,KT1, 01070000 + ISHT,IT1, 01080000 + KPBUGF,JSHOT,TOLR2,IERR,TOLR, 01090000 + ITRN, 01100000 + I20,NORTN,AXK21,AXK,KK0, 01110000 + LPOS,JPOS,IT2,T6,NPOS, 01120000 + ILHT,EX,NSHT,MSHT,IRP2,RP1,JM,JJM, 01130000 + I400,CONS,OH,ITHL,PTZ,JPTZ) 01140000 C 01150000 RETURN 01160000 C 01170000 END 01180000