CTITLESAPK19 - 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 = PICKD 00080000 C 00090000 C 00100000 C SUBROUTINE PICKD(OTR,X0,A,B,X,LEN,X1,T1,DF,NTRC,Y,SLEN,SCL,T2, 00110000 C 00120000 SUBROUTINE SAPK19(OTR,X0,A,B,X,LEN,X1,T1,DF,NTRC,Y,SLEN,SCL,T2, 00130000 + ISPLIT,NSEGMX,ILCD,NSG,T2SHFT,IFLAG,MTRC) 00140000 C 00150000 DIMENSION X(1),OTR(1),X0(NSEGMX,1),A(NSEGMX,1),B(NSEGMX,1), 00160000 + T1(1),Y(1),X1(1),T2(1),ILCD(1),NSG(1) 00170000 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 LSTART/0/ 00240000 C 00250000 IF(LSTART.NE.0) GO TO 5 00260000 LLEN3=0 00270000 TLEN=-1. 00280000 C 00290000 DO 3 I=1,MTRC 00300000 IF(ILCD(I).NE.1) GO TO 3 00310000 LLEN3=LLEN3+1 00320000 TLEN=AMAX1(TLEN,T2(I)) 00330000 3 CONTINUE 00340000 C 00350000 LSTART=INT(TLEN*20.+10.)*0.05*DF 00360000 LLEN=(LEN-LSTART)/3 00370000 IF(LLEN.GE.INT(0.25*DF)) GO TO 2 00380000 LSTART=(TLEN+0.25)*DF 00390000 LLEN=(LEN-LSTART)/3 00400000 IF(LLEN.GE.INT(0.125*DF)) GO TO 2 00410000 WRITE(IPR,1)LEN,TLEN 00420000 1 FORMAT(//' ******* INSUFFICIENT SPACE TO MOVE OUT',I8,F8.4) 00430000 LSTART=-1 00440000 GO TO 5 00450000 C 00460000 2 MLEN=LLEN/5 00470000 SLEN=SLEN/(LLEN3*LEN)*2. 00480000 IF(KPBUGF.GT.1) 00490000 +WRITE(IPR,*)LSTART,LLEN,MLEN,SLEN,TLEN 00500000 MSTART=LSTART+LLEN 00510000 LLEN3=LLEN*3 00520000 NSTART=MSTART+LLEN 00530000 SHFT=T2SHFT*DF+1.5 00540000 C 00550000 5 CONTINUE 00560000 C 00570000 CALL ARMVE(OTR,Y,LEN) 00580000 C 00590000 IF(KPBUGF.GT.2) 00600000 +WRITE(IPR,*)NTRC,ILCD(NTRC) 00610000 C 00620000 C CALL STZ(OTR,LEN) 00630000 CALL ARSET(OTR,LEN,0.) 00640000 C 00650000 IF(ILCD(NTRC).NE.1) RETURN 00660000 C 00670000 DL=X1(NTRC) 00680000 C 00690000 K=1 00700000 IF(NTRC.GT.ISPLIT) K=2 00710000 NSF=NSG(K)-1 00720000 C 00730000 IPOS=MAX0(1,KPOS(DL,NSF,X0(1,K),NSG(K),A(1,K),B(1,K),DF,LEN,I)) 00740000 C 00750000 IF(KPBUGF.GT.2) 00760000 +WRITE(IPR,30)I,DL,X0(I,K),IPOS 00770000 30 FORMAT('+',20X,I8,2F8.4,I8) 00780000 C 00790000 IF(SCL.NE.1.) DL=DL**SCL 00800000 C 00810000 IF(IFLAG.EQ.0) GO TO 55 00820000 C 00830000 IF(LSTART.LE.0) GO TO 35 00840000 G=1. 00850000 IF(NSF.GT.0) G=0.5*(1.+3.*(I-1)/NSF) 00860000 IPOS=IPOS-1+SHFT 00870000 OTR(IPOS)=-G*SLEN 00880000 C 00890000 I=LLEN 00900000 J=IPOS-MLEN 00910000 K=0 00920000 IF(J.GT.0) GO TO 33 00930000 K=J-1 00940000 I=I+K 00950000 J=1 00960000 33 CONTINUE 00970000 CALL ARMVE(Y(J),OTR(MSTART-K),I) 00980000 C 00990000 35 CONTINUE 01000000 C 01010000 IPOS=T1(NTRC)*DF+SHFT 01020000 OTR(IPOS)=SLEN 01030000 C 01040000 IF(KPBUGF.GT.2) 01050000 +WRITE(IPR,40)T1(NTRC),T2(NTRC),IPOS,G,DL 01060000 40 FORMAT('+',55X,2F8.4,I8,2F8.4) 01070000 C 01080000 IF(LSTART.LE.0) RETURN 01090000 I=LLEN 01100000 J=IPOS-MLEN 01110000 K=0 01120000 IF(J.GT.0) GO TO 50 01130000 K=J-1 01140000 I=I+K 01150000 J=1 01160000 50 CONTINUE 01170000 CALL ARMVE(Y(J),OTR(LSTART-K),I) 01180000 C 01190000 55 CONTINUE 01200000 C 01210000 IF(T2(NTRC).LT.0.) GO TO 70 01220000 IPOS=T2(NTRC)*DF+1.5 01230000 IF(IPOS.LT.2) GO TO 65 01240000 OTR(IPOS-1)=OTR(IPOS-1)+SLEN*0.5 01250000 OTR(IPOS )=OTR(IPOS )+SLEN 01260000 OTR(IPOS+1)=OTR(IPOS+1)+SLEN*0.5 01270000 65 IF(LSTART.LE.0) GO TO 70 01280000 I=LLEN 01290000 J=IPOS-MLEN 01300000 K=0 01310000 IF(J.GT.0) GO TO 60 01320000 K=J-1 01330000 I=I+K 01340000 J=1 01350000 60 CONTINUE 01360000 CALL ARMVE(Y(J),OTR(NSTART-K),I) 01370000 70 CONTINUE 01380000 C 01390000 CALL ARMPFC(OTR(LSTART),OTR(LSTART),DL,LLEN3) 01400000 C 01410000 RETURN 01420000 C 01430000 END 01440000