CTITLESAPK23 - 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 = SAPK23 00080000 C 00090000 C 00100000 C SUBROUTINE PICKI(N2,NPOS,TWK,TK,JJ,JK,KPBUGF,KP,IPR, 00110000 C 00120000 SUBROUTINE SAPK23(N2,NPOS,TWK,TK,JJ,JK,KPBUGF,KP,IPR, 00130000 + T3,YC,TWKJJ,TOLR2,IT1,ISHT,J,N1,JPOS, 00140000 + JSHTJJ,YYJJ,LPOSJJ,CONS,MM,I20,KK,MSHT,WK,IRP2, 00150000 + RP1,JM,I400,ILHT,EX,NSHT,KK1,I20M,JJM,IT1JJ,IERR)00160000 C 00170000 DIMENSION TWK(1),T3(1),YC(I20,1),TWKJJ(1), 00180000 + IT1(I20,1),ISHT(I20,1),JPOS(I20,1), 00190000 + JSHTJJ(I20,1),YYJJ(I20,1),LPOSJJ(I20,1), 00200000 + MSHT(1),WK(1),IRP2(1),RP1(1),JM(1),ILHT(1),EX(1), 00210000 + NSHT(1),JJM(1),IT1JJ(1) 00220000 C 00230000 IERR=MM 00240000 C 00250000 N1=N2 00260000 N2=NPOS 00270000 C 00280000 JK=0 00290000 C 00300000 XH=T3(J)-T3(JJ) 00310000 C 00320000 IF(KK.NE.0) GO TO 400 00330000 C 00340000 C CALL STZ(JPOS,I20M) 00350000 C CALL STZ(ISHT,I20M) 00360000 C CALL STZ(RP1,MM) 00370000 C CALL STZ(MSHT,MM) 00380000 C 00390000 CALL ARSET(JPOS,I20M,0) 00400000 CALL ARSET(ISHT,I20M,0) 00410000 CALL ARSET(RP1,MM,0.) 00420000 CALL ARSET(MSHT,MM,0) 00430000 C 00440000 C CALL PICKT(N2,TWK,XH,TK,MM,JM,YC,TWKJJ,RP1,TOLR2,JK,JPOS, 00450000 CALL SAPK33(N2,TWK,XH,TK,MM,JM,YC,TWKJJ,RP1,TOLR2,JK,JPOS, 00460000 + IT1,ISHT,MSHT,I20) 00470000 C 00480000 RETURN 00490000 C 00500000 400 CONTINUE 00510000 C 00520000 IF(KK1.EQ.0) GO TO 1000 00530000 C 00540000 C CALL STZ(IRP2,MM) 00550000 CALL ARSET(IRP2,MM,0) 00560000 C 00570000 DO 600 I=1,N2 00580000 XT=TWK(I)-XH 00590000 IS=0 00600000 IF(TWK(I).EQ.TK) IS=1 00610000 C 00620000 DO 600 K=1,MM 00630000 C 00640000 C CALL KKDEX(1,N1,YC(I,K),TWKJJ,XT,YYJJ(1,K),IN,CONS,JSHTJJ(1,K),XG)00650000 CALL SAPK10(1,N1,YC(I,K),TWKJJ,XT, 00660000 * YYJJ(1,K),IN,CONS,JSHTJJ(1,K),XG) 00670000 C 00680000 C CALL IKDEX(JPOS(I,K),LPOSJJ(IN,K),XG,TOLR2,JK, 00690000 CALL SAPK06(JPOS(I,K),LPOSJJ(IN,K),XG,TOLR2,JK, 00700000 + IT1(I,K),IN,ISHT(I,K),JSHTJJ(IN,K),IS,IRP2(K)) 00710000 C 00720000 600 CONTINUE 00730000 C 00740000 DO 700 K=1,MM 00750000 I=AMIN1(1.0001,0.5+0.05*MSHT(K))*MSHT(K) 00760000 IF(IRP2(K).LT.I) GO TO 800 00770000 MSHT(K)=IRP2(K) 00780000 700 CONTINUE 00790000 C 00800000 RETURN 00810000 C 00820000 800 CONTINUE 00830000 C 00840000 IF(KPBUGF.GT.KP) 00850000 +WRITE(IPR,650)K,(ISHT(I,K),IT1(I,K),YC(I,K),I=1,N2) 00860000 650 FORMAT(1X,I28,7X,8('|',I3,I2,F6.3)/(36X,8('|',I3,I2,F6.3))) 00870000 C 00880000 DO 950 K=1,MM 00890000 C 00900000 C CALL PICKH(YG,N1,JSHTJJ,YYJJ,IT1JJ,I20,LPOSJJ,CONS,K,I0,I1,IN,KK, 00910000 CALLSAPK22(YG,N1,JSHTJJ,YYJJ,IT1JJ,I20,LPOSJJ,CONS,K,I0,I1,IN,KK, 00920000 + I400,ILHT,EX,NSHT,EX,KPBUGF,KP,IPR,K) 00930000 C 00940000 IF(I1.NE.0) GO TO 880 00950000 JJM(K)=1 00960000 RP1(K)=CONS 00970000 DO 870 I=1,N2 00980000 ISHT(I,K)=0 00990000 JPOS(I,K)=I400 01000000 870 CONTINUE 01010000 MSHT(K)=0 01020000 IERR=IERR-1 01030000 GO TO 950 01040000 C 01050000 880 CONTINUE 01060000 JJM(K)=I1 01070000 RP1(K)=YYJJ(I1,I0) 01080000 C 01090000 DO 900 I=1,N2 01100000 ISHT(I,I0)=JSHTJJ(I1,I0) 01110000 JPOS(I,I0)=LPOSJJ(I1,I0) 01120000 900 CONTINUE 01130000 C 01140000 MSHT(I0)=ISHT(1,I0) 01150000 C 01160000 950 CONTINUE 01170000 C 01180000 IF(IERR.EQ.0) RETURN 01190000 C 01200000 KK1=0 01210000 JK=0 01220000 C 01230000 1000 CONTINUE 01240000 C 01250000 C CALL PICKT(N2,TWK,XH,TK,MM,JJM,YC,TWKJJ,RP1,TOLR2,JK,JPOS, 01260000 CALL SAPK33(N2,TWK,XH,TK,MM,JJM,YC,TWKJJ,RP1,TOLR2,JK,JPOS, 01270000 + IT1,ISHT,MSHT,I20) 01280000 C 01290000 RETURN 01300000 C 01310000 END 01320000