CTITLESAPK17 - 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 = PICKB 00080000 C 00090000 C 00100000 C SUBROUTINE PICKB(NSEGMX,X,RA,IND0,INX0,TRC,ISPL, 00110000 C 00120000 SUBROUTINE SAPK17(NSEGMX,X,RA,IND0,INX0,TRC,ISPL, 00130000 + XL,A,B,IERR,NSG,INTT,JSHOT,LSHOT,INP,XNR,IFLAG) 00140000 C 00150000 DIMENSION RA(1),X(1),TRC(1),ISPL(1),XL(NSEGMX,1),A(NSEGMX,1), 00160000 + B(NSEGMX,1),NSG(2), NXX(2), LSHOT(1),INP(1) 00170001 C 00180000 COMMON/IND/INXT,INX2,NSEG,NSEF,NSEH,NX,INXX,INTX,NS 00190000 + ,INDI,INDJ,INDK,INJJ,INKK,INJ0,INK0,INII,INI0 00200000 + ,MX,INX1,INT1,INXP,INNS,INYJ,INGK,INAL,INWK 00210000 + ,ISXC,IXC2,IXCD,INSD,ININ,IWK1,SUMRE,IPR,DX,KPBUGF,CONS 00220000 C 00230000 DATA MINC/99999/ 00240000 C 00250000 DO 10 I=1,NS 00260000 C 00270000 KK=INP(I) 00280000 RA(INNS+I-1)=TRC(KK) 00290000 C 00300000 IF(LSHOT(KK).NE.JSHOT) MINC=MIN0(MINC,IABS(JSHOT-LSHOT(KK))) 00310000 10 CONTINUE 00320000 NINC=MINC*(NS/2) 00330000 C 00340000 NSG(1)=0 00350000 NSG(2)=0 00360000 C 00370000 DO 500 KK=1,2 00380000 C 00390000 C CALL STZ(RA(INI0),IND0-INI0+1) 00400000 CALL ARSET(RA(INI0),IND0-INI0+1,0.) 00410000 C 00420000 NSEF=0 00430000 NSEG=1 00440000 NSEH=2 00450000 C 00460000 C CALL ROBS(RA(INXT),RA(INX2),X,RA(INX0),RA, 00470000 CALL SAPK40(RA(INXT),RA(INX2),X,RA(INX0),RA, 00480000 + ISPL,KK,INTT,NINC,JSHOT,LSHOT,INP,XNR) 00490000 C 00500000 NXX(KK)=NX 00510000 IF(NX.LT.2.OR.RA(INDJ).LE.0.) GO TO 500 00520000 C 00530000 JSEG=NSEG 00540000 C XF=F(X,RA) 00550000 XF=SUMRE 00560000 C 00570000 RA(INJ0)=RA(INDJ) 00580000 RA(INK0)=RA(INDK) 00590000 C 00600000 IF(KPBUGF.LT.1) GO TO 2 00610000 WRITE(IPR, *)JSEG,XF 00620000 WRITE(IPR, *)RA(INJ0) 00630000 WRITE(IPR, *)RA(INK0) 00640000 2 CONTINUE 00650000 C 00660000 IF(NSEGMX.LT.2) GO TO 200 00670000 IOP=0 00680000 DO 100 NSEG=2,NSEGMX 00690000 C 00700000 IF(KPBUGF.GT.0) 00710000 +WRITE(IPR, 1)NSEG 00720000 1 FORMAT(///1X,120('*')//' NSEG=',I5/) 00730000 C 00740000 C CALL STZ(RA(INDI),IND0-INDI+1) 00750000 CALL ARSET(RA(INDI),IND0-INDI+1,0.) 00760000 C 00770000 NSEF=NSEG-1 00780000 NSEH=NSEG+1 00790000 C 00800000 C CALL ROB1(RA(INXT),RA(INX2),X,RA(INX0),RA) 00810000 CALL SAPK41(RA(INXT),RA(INX2),X,RA(INX0),RA) 00820000 C CALL OPT2T(XF,X,RA(INX0),RA(INXT),JSEG,IOP,RA,0,1,JSHOT,IFLAG) 00830000 CALL SAPK14(XF,X,RA(INX0),RA(INXT),JSEG,IOP,RA,0,1,JSHOT,IFLAG) 00840000 IF(IOP.NE.0) GO TO 200 00850000 C 00860000 IF(KPBUGF.GT.0) 00870000 +WRITE(IPR, *)JSEG 00880000 100 CONTINUE 00890000 C 00900000 200 CONTINUE 00910000 NSEG=JSEG 00920000 NSEF=NSEG-1 00930000 NSEH=NSEG+1 00940000 C 00950000 IF(NSEG.LT.3) GO TO 300 00960000 C 00970000 CALL ARMVE(RA(INI0),X,NSEF) 00980000 C 00990000 C CALL OPT2T(XF,X,RA(INX0),RA(INXT),JSEG,IOP,RA,NSEG,-1,JSHOT,IFLAG)01000000 CALL SAPK14(XF,X,RA(INX0),RA(INXT), 01010000 * JSEG,IOP,RA,NSEG,-1,JSHOT,IFLAG) 01020000 C 01030000 300 CONTINUE 01040000 IOP=0 01050000 C 01060000 XF=XF/NX 01070000 XL(NSEG,KK)=XF 01080000 C 01090000 IF(IFLAG.EQ.0) GO TO 400 01100000 WRITE(IPR, *)JSHOT,NSEG,XF,NX 01110000 WRITE(IPR, *)(RA(INI0+I-1),I=1,NSEF) 01120000 WRITE(IPR, *)(RA(INJ0+I-1),I=1,NSEG) 01130000 WRITE(IPR, *)(RA(INK0+I-1),I=1,NSEG) 01140000 C 01150000 400 CONTINUE 01160000 NSG(KK)=NSEG 01170000 CALL ARMVE(RA(INI0),XL(1,KK),NSEF) 01180000 CALL ARMVE(RA(INJ0),A(1,KK),NSEG) 01190000 CALL ARMVE(RA(INK0),B(1,KK),NSEG) 01200000 C 01210000 500 CONTINUE 01220000 C 01230000 IERR=0 01240000 I=NXX(1) 01250000 DO 600 KK=1,2 01260000 IF(NXX(KK).LT.2) IERR=IERR+1 01270000 IF(NXX(KK).LE.I) J=KK 01280000 600 CONTINUE 01290000 C 01300000 IF(IERR.GT.1) RETURN 01310000 IF(NXX(J).GT.8) RETURN 01320000 IF(NXX(J).GT.0.AND.NXX(J).LT.9) GO TO 610 01330000 C CALL NXTEST(RA(INT1),RA(INNS),MX,NS,I) 01340000 CALL SAPK13(RA(INT1),RA(INNS),MX,NS,I) 01350000 IF(I.LT.NS) RETURN 01360000 610 I=1 01370000 IF(NXX(1).GT.NXX(2)) I=-1 01380000 NSG(J)=NSG(I+J) 01390000 CALL ARMVE(XL(1,I+J),XL(1,J),NSG(J)) 01400000 CALL ARMVE(A(1,I+J),A(1,J),NSG(J)) 01410000 CALL ARMVE(B(1,I+J),B(1,J),NSG(J)) 01420000 IF(IFLAG.NE.0) 01430000 +WRITE(IPR,620)JSHOT,J 01440000 620 FORMAT(//' ***** NOTE *****',5X,'INSUFFICIENT DATA POINTS AT SHOT 01450000 +=',I6,', SPLIT SIDE =',I3,5X,'USE OTHER SIDE''S SEGMENT'//) 01460000 C 01470000 RETURN 01480000 C 01490000 END 01500000