CTITLESAPK22 - 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 = PICKH 00080000 C 00090000 C 00100000 C SUBROUTINE PICKH(XG,N2,ISHT,YC,IT2,I20,JPOS,CONS,N0,I0,I2,IN,IK, 00110000 C 00120000 SUBROUTINE SAPK22(XG,N2,ISHT,YC,IT2,I20,JPOS,CONS,N0,I0,I2,IN,IK, 00130000 + I400,ILHT,EX,NSHT,IEX,KPBUGF,KP,IPR,M0) 00140000 C 00150000 DIMENSION ISHT(I20,1),YC(I20,1),IT2(I20,1),JPOS(I20,1), 00160000 + ILHT(I400,1),EX(I400,1),NSHT(I20,I20,1),IEX(I400,1) 00170000 C 00180000 XG=CONS 00190000 JK=0 00200000 IL=0 00210000 C 00220000 DO 1100 I=M0,N0 00230000 DO 1100 K=1,N2 00240000 JS=ISHT(K,I)-JPOS(K,I) 00250000 IF(JK.GT.JS) GO TO 1100 00260000 IF(JK.LT.JS) GO TO 1050 00270000 IF(JPOS(K,I).GT.IL) GO TO 1100 00280000 IF(JPOS(K,I).LT.IL) GO TO 1050 00290000 IF(YC(K,I).GE.XG) GO TO 1100 00300000 1050 CONTINUE 00310000 JK=JS 00320000 XG=YC(K,I) 00330000 IL=JPOS(K,I) 00340000 I0=I 00350000 I2=K 00360000 1100 CONTINUE 00370000 C 00380000 IF(JK.GT.0) GO TO 1110 00390000 I2=0 00400000 RETURN 00410000 C 00420000 1110 CONTINUE 00430000 C 00440000 JK=JK*0.25*(1.+2.*JK/IK)+0.5 00450000 C 00460000 JL=0 00470000 DO 1200 I=M0,N0 00480000 DO 1200 K=1,N2 00490000 NSHT(K,I,1)=0 00500000 IF(ISHT(K,I)-JPOS(K,I).LT.JK) GO TO 1200 00510000 JS=100*K+I 00520000 C 00530000 IF(JL.LT.1) GO TO 1140 00540000 DO 1130 I1=1,JL 00550000 IF(JPOS(K,I).NE.IEX(I1,1).OR.ISHT(K,I)+IEX(I1,2).NE.IK) GO TO 113000560000 I2=ILHT(I1,1)/100 00570000 I0=ILHT(I1,1)-100*I2 00580000 IF(IT2(K,I).NE.IT2(I2,I0)) GO TO 1130 00590000 IF(YC(K,I).GE.EX(I1,3)) GO TO 1200 00600000 C 00610000 DO 1120 J=1,3 00620000 ILHT(I1,J)=JS 00630000 1120 CONTINUE 00640000 C 00650000 EX(I1,3)=YC(K,I) 00660000 GO TO 1200 00670000 1130 CONTINUE 00680000 C 00690000 1140 CONTINUE 00700000 JL=JL+1 00710000 DO 1150 J=1,3 00720000 ILHT(JL,J)=JS 00730000 1150 CONTINUE 00740000 IEX(JL,1)=JPOS(K,I) 00750000 IEX(JL,2)=IK-ISHT(K,I) 00760000 EX(JL,3)=YC(K,I) 00770000 1200 CONTINUE 00780000 C 00790000 DO 1300 J=1,3 00800000 C CALL MORDR(JL,IEX(1,J),ILHT(1,J),I,K) 00810000 CALL SAPK12(JL,IEX(1,J),ILHT(1,J),I,K) 00820000 1300 CONTINUE 00830000 C 00840000 DO 1400 J=1,3 00850000 I1=-1 00860000 JS=0 00870000 DO 1400 I=1,JL 00880000 IF(IEX(I,J).EQ.I1) GO TO 1350 00890000 I1=IEX(I,J) 00900000 IF(J.EQ.2) JS=JS+1 00910000 IF(J.NE.2) JS=I 00920000 1350 CONTINUE 00930000 K=ILHT(I,J)/100 00940000 IN=ILHT(I,J)-K*100 00950000 NSHT(K,IN,J)=JS 00960000 1400 CONTINUE 00970000 C 00980000 XG=CONS 00990000 CALL ARMVE(CONS,I1,1) 01000000 I2=0 01010000 IL=0 01020000 IN=0 01030000 DO 1500 I=M0,N0 01040000 DO 1500 K=1,N2 01050000 IF(NSHT(K,I,1).EQ.0) GO TO 1500 01060000 JS=0 01070000 DO 1450 J=1,3 01080000 JS=JS+NSHT(K,I,J) 01090000 1450 CONTINUE 01100000 IF(JS.GT.I1) GO TO 1500 01110000 IF(JS.LT.I1) GO TO 1460 01120000 IF(JPOS(K,I).GT.IL) GO TO 1500 01130000 IF(JPOS(K,I).LT.IL) GO TO 1460 01140000 IF(ISHT(K,I).LT.IN) GO TO 1500 01150000 IF(ISHT(K,I).GT.IN) GO TO 1460 01160000 IF(YC(K,I).GE.XG) GO TO 1500 01170000 1460 CONTINUE 01180000 I1=JS 01190000 IL=JPOS(K,I) 01200000 IN=ISHT(K,I) 01210000 XG=YC(K,I) 01220000 I0=I 01230000 I2=K 01240000 1500 CONTINUE 01250000 C 01260000 IF(I2.EQ.0) RETURN 01270000 C 01280000 IN=IT2(I2,I0) 01290000 C 01300000 IF(KPBUGF.GT.KP) WRITE(IPR,*)I0,I2,(NSHT(I2,I0,J),J=1,3),JK 01310000 C 01320000 RETURN 01330000 C 01340000 END 01350000