CTITLESAPK25 - 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 = PICKK               00080000
C    REVISED              09/15/89  LWC  FIX CODING BUG AS REQUESTED    00081000
C                                   BY P. LUH                           00082000
C                                                                       00090000
C                                                                       00100000
C     SUBROUTINE PICKK(JSHOT,X1,K1,K2,KPBUGF,ILCD,L,KTR,MST,IPR,IER,    00110000
C                                                                       00120000
      SUBROUTINE SAPK25(JSHOT,X1,K1,K2,KPBUGF,ILCD,L,KTR,MST,IPR,IER,   00130000
     +                 IFIRST,KK0,CONS,JFIRST)                          00140000
C                                                                       00150000
      DIMENSION  X1(1),KTR(1),ILCD(1)                                   00160000
C                                                                       00170000
      IER=0                                                             00180000
C                                                                       00190000
      L=0                                                               00200000
      DO 81 I=K1,K2                                                     00210000
      IF(ILCD(I).NE.1) GO TO 81                                         00220000
      L=L+1                                                             00230000
C                                                                       00240000
      IF(L.GE.IFIRST) GO TO 84                                          00250000
   81 CONTINUE                                                          00260000
C                                                                       00270000
      IER=1                                                             00280000
C                                                                       00290000
      IF(JFIRST.NE.0)                                                   00300000
     +WRITE(IPR,140)JSHOT,KK0,K1,K2,(ILCD(I),I=K1,K2)                   00310000
  140 FORMAT(' ***** NOTE - PICKK *****',5X,'INSUFFICIENT LIVE TRACES PR00320000
     +ESENT AT SHOT =',I6,5X,'SPLIT SIDE =',I3,5X,'(K1,K2)=(',I4,',',I4,00330000
     +')'/(20X,50I2))                                                   00340000
      RETURN                                                            00350000
C                                                                       00360000
   84 CONTINUE                                                          00370000
C                                                                       00380000
      IF(IFIRST.EQ.MST) RETURN                                          00390000
C                                                                       00400000
      IFIRST=MST                                                        00410000
C                                                                       00420000
      IF((X1(K1)-1.)*(X1(K2)-1.).LT.0.) GO TO 60                        00430000
      J=K1                                                              00440000
      IF(X1(K1).LT.X1(K2)) GO TO 50                                     00450000
      IF(X1(K2).GT.1.) J=K2                                             00460000
      GO TO 80                                                          00470000
   50 IF(X1(K2).LT.1.) J=K2                                             00480000
      GO TO 80                                                          00490000
   60 XG=CONS                                                           00500000
      DO 70 I=K1,K2                                                     00510000
      IF(XG.LE.ABS(1.-X1(I))) GO TO 70                                  00520000
      XG=ABS(1.-X1(I))                                                  00530000
      J=I                                                               00540000
   70 CONTINUE                                                          00550000
C                                                                       00560000
   80 CONTINUE                                                          00570000
      IF(KPBUGF.GT.1)                                                   00580000
     +WRITE(IPR,*)J                                                     00590000
C                                                                       00600000
      NST=L                                                             00610000
      NSH=(L+1)/2                                                       00620000
C                                                                       00630000
      L=0                                                               00640000
      DO 90 I=J,K2                                                      00650000
      IF(ILCD(I).NE.1) GO TO 90                                         00660000
      L=L+1                                                             00670000
      KTR(L)=I                                                          00680000
      IF(L.EQ.NSH) GO TO 100                                            00690000
   90 CONTINUE                                                          00700000
  100 LL=L                                                              00710000
      IF(J.EQ.K1) GO TO 120                                             00720000
      K=J-1                                                             00730000
      DO 110 I=K,K1,-1                                                  00740000
      IF(ILCD(I).NE.1) GO TO 110                                        00750000
      L=L+1                                                             00760000
      KTR(L)=I                                                          00770000
      IF(L.EQ.NST) GO TO 150                                            00780000
  110 CONTINUE                                                          00790000
  120 K=KTR(LL)+1                                                       00800000
      DO 130 I=K,K2                                                     00810000
      IF(ILCD(I).NE.1) GO TO 130                                        00820000
      L=L+1                                                             00830000
      KTR(L)=I                                                          00840000
      IF(L.EQ.NST) GO TO 150                                            00850000
  130 CONTINUE                                                          00860000
C                                                                       00870000
  150 CONTINUE                                                          00880000
      IF(KPBUGF.GT.1)                                                   00890000
     +WRITE(IPR,*)(KTR(I),I=1,L)                                        00900000
C                                                                       00910000
      RETURN                                                            00920000
C                                                                       00930000
      END                                                               00940000