CTITLESAPK21 - 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 = PICKG 00080000 C 00090000 C 00100000 C SUBROUTINE PICKG(IPR,T6,I20,TWK, 00110000 C 00120000 SUBROUTINE SAPK21(IPR,T6,I20,TWK, 00130000 + WK,KPBUGF,KP, 00140000 + JSHOT,IK,KT1,JSHT,YY,T4,YC, 00150000 + TOLR2,IT1,ISHT,NPOS,LPOS,JPOS,CONS,MM,IJ,IT2,T2, 00160000 + ILHT,EX,NSHT,I400,MSHT,IRP2,IRP1,JM,JJM) 00170000 C 00180000 DIMENSION T6(1),TWK(I20,1),WK(I20,1),KT1(1), 00190000 + JSHT(I20,I20,1),YY(I20,I20,1),T4(1),YC(I20,1), 00200000 + IT1(I20,I20,1),ISHT(I20,1),NPOS(1),LPOS(I20,I20,1), 00210000 + JPOS(I20,1),IT2(I20,1),T2(1), 00220000 + ILHT(1),EX(1),NSHT(1),MSHT(1),IRP2(1),IRP1(1),JM(1), 00230000 + JJM(1) 00240000 C 00250000 IF(KPBUGF.GT.KP) WRITE(IPR,*)JSHOT,KT1(IJ),MM 00260000 C 00270000 DO 1000 I=1,MM 00280000 JM(I)=I 00290000 1000 CONTINUE 00300000 C 00310000 J2=KT1(IJ) 00320000 N2=MM 00330000 C 00340000 I20M=I20*MM 00350000 C CALL STZ(JSHT(1,1,J2),I20M) 00360000 C CALL STZ(YY(1,1,J2),I20M) 00370000 C CALL STZ(LPOS(1,1,J2),I20M) 00380000 C 00390000 CALL ARSET(JSHT(1,1,J2),I20M,0) 00400000 CALL ARSET(YY(1,1,J2),I20M,0.) 00410000 CALL ARSET(LPOS(1,1,J2),I20M,0) 00420000 C 00430000 IF(IJ.EQ.IK) GO TO 1150 00440000 C 00450000 KK=0 00460000 KK1=1 00470000 JJ=IJ+1 00480000 DO 1100 I=JJ,IK 00490000 J=KT1(I) 00500000 C 00510000 C CALL PICKL(IPR,T6(J),I20,TWK(1,J),I20M,I,KT1, 00520000 CALL SAPK26(IPR,T6(J),I20,TWK(1,J),I20M,I,KT1, 00530000 + J,KPBUGF,KP,WK(1,J), 00540000 + IK,N2,JSHT(1,1,J),YY(1,1,J),J2,T4, 00550000 + YC,TWK(1,J2),T2(J), 00560000 + TOLR2,IT1(1,1,J),ISHT,NPOS(J),LPOS(1,1,J),JPOS, 00570000 + JSHT(1,1,J2),YY(1,1,J2),LPOS(1,1,J2),CONS,MM,KK, 00580000 + MSHT,IRP2,IRP1,JM,I400,ILHT,EX,NSHT,KK1,JJM, 00590000 + IT1(1,1,J2),I2) 00600000 C 00610000 IF(I2.EQ.0) GO TO 1450 00620000 C 00630000 1100 CONTINUE 00640000 C 00650000 1150 CONTINUE 00660000 C 00670000 J0=KT1(IJ) 00680000 N0=MM 00690000 C 00700000 IF(IJ.EQ.1) GO TO 1210 00710000 C 00720000 KK=0 00730000 KK1=1 00740000 JJ=IJ-1 00750000 DO 1200 I=JJ,1,-1 00760000 J=KT1(I) 00770000 C 00780000 C CALL PICKL(IPR,T6(J),I20,TWK(1,J),I20M,I,KT1, 00790000 CALL SAPK26(IPR,T6(J),I20,TWK(1,J),I20M,I,KT1, 00800000 + J,KPBUGF,KP,WK(1,J), 00810000 + IK,N0,JSHT(1,1,J),YY(1,1,J),J0,T4, 00820000 + YC,TWK(1,J0),T2(J), 00830000 + TOLR2,IT1(1,1,J),ISHT,NPOS(J),LPOS(1,1,J),JPOS, 00840000 + JSHT(1,1,J0),YY(1,1,J0),LPOS(1,1,J0),CONS,MM,KK, 00850000 + MSHT,IRP2,IRP1,JM,I400,ILHT,EX,NSHT,KK1,JJM, 00860000 + IT1(1,1,J0),I2) 00870000 C 00880000 IF(I2.EQ.0) GO TO 1450 00890000 C 00900000 1200 CONTINUE 00910000 C 00920000 1210 CONTINUE 00930000 C 00940000 I0=0 00950000 1220 CONTINUE 00960000 IF(I0.GE.IK) GO TO 1250 00970000 I0=I0+1 00980000 IF(KT1(I0).GT.0) GO TO 1220 00990000 IN=I0+1 01000000 C 01010000 DO 1230 I2=IN,IK 01020000 KT1(I2-1)=KT1(I2) 01030000 1230 CONTINUE 01040000 C 01050000 IK=IK-1 01060000 I0=I0-1 01070000 IF(IJ.LE.I0) GO TO 1220 01080000 IF(IJ.GT.1) IJ=IJ-1 01090000 GO TO 1220 01100000 1250 CONTINUE 01110000 C 01120000 IF(IK.EQ.0) RETURN 01130000 C 01140000 C CALL PICKQ(IPR,I20,N0,J0,N2,J2, 01150000 CALL SAPK30(IPR,I20,N0,J0,N2,J2, 01160000 + KPBUGF,KP, 01170000 + JSHOT,IK,JSHT,YY,YC, 01180000 + ISHT,LPOS,JPOS,CONS,MM,IJ,IT2,I20M) 01190000 C 01200000 C CALL PICKH(XG,N2,ISHT,YC,IT2,I20,JPOS,CONS,N0,I0,I2,IN,IK,I400, 01210000 CALL SAPK22(XG,N2,ISHT,YC,IT2,I20,JPOS,CONS,N0,I0,I2,IN,IK,I400, 01220000 + ILHT,EX,NSHT,EX,KPBUGF,KP,IPR,1) 01230000 C 01240000 IF(I2.GT.0) GO TO 1400 01250000 C 01260000 C IF(KPBUGF.LE.KP) CALL PICKS(KPBUGF,IPR,T6,I20,TWK,WK,NPOS,JSHOT, 01270000 IF(KPBUGF.LE.KP) CALL SAPK32(KPBUGF,IPR,T6,I20,TWK,WK,NPOS,JSHOT, 01280000 + T4,KT1,IK,JSHT,IT1,YY,MM,IJ,ISHT,YC, 01290000 + IT2,JPOS,N0,N2) 01300000 C 01310000 GO TO 1450 01320000 C 01330000 1400 CONTINUE 01340000 IF(IJ.NE.IK) GO TO 1420 01350000 JJ=I0 01360000 I0=I2 01370000 I2=JJ 01380000 C 01390000 1420 CONTINUE 01400000 C 01410000 IF(KPBUGF.LE.KP) GO TO 1450 01420000 WRITE(IPR,1004)I0,IN,J0,JSHT(I0,IN,J0),LPOS(I0,IN,J0),YY(I0,IN,J0)01430000 WRITE(IPR,1004)I2,IN,J2,JSHT(I2,IN,J2),LPOS(I2,IN,J2),YY(I2,IN,J2)01440000 1004 FORMAT(1X,5I6,F7.3) 01450000 C 01460000 1450 CONTINUE 01470000 C 01480000 C CALL PICKM(IT1,T2,TWK,I20,KT1,IK,IJ,I0,I2,J0,J2,IN) 01490000 CALL SAPK27(IT1,T2,TWK,I20,KT1,IK,IJ,I0,I2,J0,J2,IN) 01500000 C 01510000 IF(KPBUGF.GT.KP) 01520000 +WRITE(IPR,1002)JSHOT,KT1(IJ),MM,XG,(KT1(I),T2(KT1(I)),I=1,IK) 01530000 1002 FORMAT(1X,3I6,F7.3/(10X,12(I4,F6.3))) 01540000 C 01550000 RETURN 01560000 C 01570000 END 01580000