CTITLESAPK14 - 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 = OPT2T 00080000 C 00090000 C 00100000 C SUBROUTINE OPT2T(XF,XL,IX,XOFF,JSEG,IOP,X,I0,I1,JSHOT,IFLAG) 00110000 C 00120000 SUBROUTINE SAPK14(XF,XL,IX,XOFF,JSEG,IOP,X,I0,I1,JSHOT,IFLAG) 00130000 C 00140000 DIMENSION X(1),IX(1),XOFF(1),XL(1) 00150000 C 00160000 COMMON/IND/INXT,INX2,NSEG,NSEF,NSEH,NX,INXX,INTX,NS 00170000 + ,INDI,INDJ,INDK,INJJ,INKK,INJ0,INK0,INII,INI0 00180000 + ,MX,INX1,INT1,INXP,INNS,INYJ,INGK,INAL,INWK 00190000 + ,ISXC,IXC2,IXCD,INSD,ININ,IWK1,SUMRE,IPR,DX,KPBUGF,CONS 00200000 C 00210000 IF(KPBUGF.GT.0) 00220000 +WRITE(IPR, *)(XL(I),I=1,NSEF) 00230000 C 00240000 IS=0 00250000 XL(NSEG)=CONS 00260000 C 00270000 I=1 00280000 J=0 00290000 IX(I)=0 00300000 20 J=J+1 00310000 IF(XOFF(J).LE.XL(I)) GO TO 20 00320000 C 00330000 IF(J-IX(I).GT.6.OR.I1.LT.0) GO TO 30 00340000 IF(NX-IX(I).LT.12.OR.I.EQ.NSEF) GO TO 60 00350000 IF(KPBUGF.GT.0) 00360000 +WRITE(IPR, *)J,IX(I),XL(I),XOFF(J) 00370000 C 00380000 XL(I)=0.5*(XOFF(IX(I)+6)+XOFF(IX(I)+7)) 00390000 GO TO 20 00400000 30 I=I+1 00410000 IX(I)=J-1 00420000 IF(I.LT.NSEG) GO TO 20 00430000 C 00440000 33 CONTINUE 00450000 IF(KPBUGF.GT.0) 00460000 +WRITE(IPR, *)(I,IX(I),XL(I),I=1,NSEG) 00470000 K=0 00480000 FX=CONS 00490000 I=I0 00500000 40 K1=K 00510000 K=K+1 00520000 I=MOD(I+I1,NSEF) 00530000 IF(I.EQ.0) I=NSEF 00540000 C CALL SRCH(I,XL,IX,X(INXT),X) 00550000 CALL SAPK45(I,XL,IX,X(INXT),X) 00560000 IF(KPBUGF.GT.0) 00570000 +WRITE(IPR, 41)K,(J,IX(J),XL(J),J=1,NSEG) 00580000 41 FORMAT(/' ++++',I5/(1X,6(2I4,G12.5))) 00590000 FY=SUMRE 00600000 IF(KPBUGF.GT.0) 00610000 +WRITE(IPR, *)K,FX,FY,XF 00620000 FXY=FX/FY 00630000 C 00640000 IF(FY.LT.FX) GO TO 50 00650000 C 00660000 44 CONTINUE 00670000 DO 45 J=1,K1 00680000 IF(FY.NE.X(INTX+J-1)) GO TO 45 00690000 IS=IS+1 00700000 IF(IS.GT.NSEH) GO TO 56 00710000 45 CONTINUE 00720000 GO TO 55 00730000 C 00740000 50 CONTINUE 00750000 DO 54 J=1,NSEG 00760000 IF(X(INDJ+J-1).LE.0.) GO TO 44 00770000 54 CONTINUE 00780000 C 00790000 FX=FY 00800000 CALL ARMVE(XL,X(INII),NSEF) 00810000 CALL ARMVE(X(INDJ),X(INJJ),NSEG) 00820000 CALL ARMVE(X(INDK),X(INKK),NSEG) 00830000 55 CONTINUE 00840000 X(INTX+K-1)=FY 00850000 IF((ABS(1.-FXY).GT.1.E-3.AND.NSEF.NE.1).OR.K.LT.NSEF) GO TO 40 00860000 C 00870000 56 CONTINUE 00880000 DO 57 J=1,NSEF 00890000 IF(X(INJJ+J).GE.X(INJJ+J-1)) GO TO 80 00900000 57 CONTINUE 00910000 C 00920000 IF(XF.LT.FX) GO TO 80 00930000 C 00940000 JSEG=NSEG 00950000 XF=FX 00960000 CALL ARMVE(X(INII),X(INI0),NSEF) 00970000 CALL ARMVE(X(INJJ),X(INJ0),JSEG) 00980000 CALL ARMVE(X(INKK),X(INK0),JSEG) 00990000 C 01000000 IF(KPBUGF.LT.1) RETURN 01010000 WRITE(IPR, *)JSEG,XF 01020000 WRITE(IPR, *)(X(INI0+I-1),I=1,NSEF) 01030000 WRITE(IPR, *)(X(INJ0+I-1),I=1,JSEG) 01040000 WRITE(IPR, *)(X(INK0+I-1),I=1,JSEG) 01050000 RETURN 01060000 C 01070000 60 CONTINUE 01080000 IF(IFLAG.NE.0) 01090000 +WRITE(IPR, 70)JSHOT,NSEG 01100000 70 FORMAT(/' $$$$ WARNING OPT2 $$$$',10X,'BAD SAMPLES; NO ANALYSIS AT01110000 + SHOT POINT =',I8,5X,'NSEG =',I5/) 01120000 C 01130000 80 IOP=1 01140000 IF(KPBUGF.GT.0) 01150000 +WRITE(IPR, 90) 01160000 90 FORMAT(' $$$$$$$$$ + RETURN SAPK14'///) 01170000 C 01180000 RETURN 01190000 C 01200000 END 01210000