SUBROUTINE ABSNT(A,S,NO,NV) DIMENSION A(1),S(1) DO 20 J=1,NO IJ=J-NO S(J)=1.0 DO 10 I=1,NV IJ=IJ+NO IF(A(IJ)) 10,5,10 5 S(J)=0 GO TO 20 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ACFI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) IER=2 IF(NDIM)20,20,1 1 Y=VAL(1) DELT2=0. IF(NDIM-1)20,20,2 2 P2=1. P3=Y Q2=0. Q3=1. DO 16 I=2,NDIM II=0 P1=P2 P2=P3 Q1=Q2 Q2=Q3 Z=Y DELT1=DELT2 JEND=I-1 3 AUX=VAL(I) DO 10 J=1,JEND H=VAL(I)-VAL(J) IF(ABS(H)-1.E-6*ABS(VAL(I)))4,4,9 4 IF(ARG(I)-ARG(J))5,17,5 5 IF(J-JEND)8,6,6 6 II=II+1 III=I+II IF(III-NDIM)7,7,19 7 VAL(I)=VAL(III) VAL(III)=AUX AUX=ARG(I) ARG(I)=ARG(III) ARG(III)=AUX GOTO 3 8 VAL(I)=1.E33 GOTO 10 9 VAL(I)=(ARG(I)-ARG(J))/H 10 CONTINUE P3=VAL(I)*P2+(X-ARG(I-1))*P1 Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1 IF(Q3)11,12,11 11 Y=P3/Q3 GOTO 13 12 Y=1.E33 13 DELT2=ABS(Z-Y) IF(DELT2-EPS)19,19,14 14 IF(I-8)16,15,15 15 IF(DELT2-DELT1)16,18,18 16 CONTINUE RETURN 17 IER=3 RETURN 18 Y=Z IER=1 RETURN 19 IER=0 20 RETURN END SUBROUTINE AHI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) IER=2 H2=X-ARG(1) IF(NDIM-1)2,1,3 1 Y=VAL(1)+VAL(2)*H2 2 RETURN 3 I=1 DO 5 J=2,NDIM H1=H2 H2=X-ARG(J) Y=VAL(I) VAL(I)=Y+VAL(I+1)*H1 H=H1-H2 IF(H)4,13,4 4 VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H 5 I=I+2 VAL(I)=VAL(I)+VAL(I+1)*H2 DELT2=0. IEND=I-1 DO 9 I=1,IEND DELT1=DELT2 Y=VAL(1) M=(I+3)/2 H1=ARG(M) DO 6 J=1,I K=I+1-J L=(K+1)/2 H=ARG(L)-H1 IF(H)6,14,6 6 VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H DELT2=ABS(Y-VAL(1)) IF(DELT2-EPS)11,11,7 7 IF(I-5)9,8,8 8 IF(DELT2-DELT1)9,12,12 9 CONTINUE 10 Y=VAL(1) RETURN 11 IER=0 GOTO 10 12 IER=1 RETURN 13 Y=VAL(1) 14 IER=3 RETURN END SUBROUTINE ALI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) IER=2 DELT2=0. IF(NDIM-1)9,7,1 1 DO 6 J=2,NDIM DELT1=DELT2 IEND=J-1 DO 2 I=1,IEND H=ARG(I)-ARG(J) IF(H)2,13,2 2 VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H DELT2=ABS(VAL(J)-VAL(IEND)) IF(J-2)6,6,3 3 IF(DELT2-EPS)10,10,4 4 IF(J-5)6,5,5 5 IF(DELT2-DELT1)6,11,11 6 CONTINUE 7 J=NDIM 8 Y=VAL(J) 9 RETURN 10 IER=0 GOTO 8 11 IER=1 12 J=IEND GOTO 8 13 IER=3 GOTO 12 END SUBROUTINE APCH(DATI,N,IP,XD,X0,WORK,IER) DIMENSION DATI(1),WORK(1) IF(N-1)19,20,1 1 IF(IP)19,19,2 2 IF(IP-N)3,3,19 3 XA=DATI(1) X0=XA XE=0. DO 7 I=1,N XM=DATI(I) IF(XA-XM)5,5,4 4 XA=XM 5 IF(X0-XM)6,7,7 6 X0=XM 7 CONTINUE XD=X0-XA M=(IP*(IP+1))/2 IEND=M+IP+1 MT2=IP+IP MT2M=MT2-1 DO 8 I=1,IP J=MT2-I WORK(J)=0. WORK(I)=0. K=M+I 8 WORK(K)=0. IF(XD)20,20,9 9 X0=-(X0+XA)/XD XD=2./XD SUM=0. DO 15 I=1,N T=DATI(I)*XD+X0 J=I+N DF=DATI(J) XA=1. XM=T IF(DATI(2*N+1))11,11,10 10 J=J+N XA=DATI(J) XM=T*XA 11 T=T+T SUM=SUM+DF*DF*XA DF=DF+DF J=1 12 K=M+J WORK(K)=WORK(K)+DF*XA 13 WORK(J)=WORK(J)+XA IF(J-MT2M)14,15,15 14 J=J+1 XE=T*XM-XA XA=XM XM=XE IF(J-IP)12,12,13 15 CONTINUE WORK(IEND)=SUM+SUM LL=M KK=MT2M JJ=1 K=KK DO 18 J=1,M WORK(LL)=WORK(K)+WORK(JJ) LL=LL-1 IF(K-JJ)16,16,17 16 KK=KK-2 K=KK JJ=1 GOTO 18 17 JJ=JJ+1 K=K-1 18 CONTINUE IER=0 RETURN 19 IER=-1 RETURN 20 IER=1 RETURN END SUBROUTINE APFS(WORK,IP,IRES,IOP,EPS,ETA,IER) DIMENSION WORK(1) IRES=0 IF(IP)1,1,2 1 IER=-1 RETURN 2 IPIV=0 IPP1=IP+1 IER=1 ITE=IP*IPP1/2 IEND=ITE+IPP1 TOL=ABS(EPS*WORK(1)) TEST=ABS(ETA*WORK(IEND)) DO 11 I=1,IP IPIV=IPIV+I JA=IPIV-IRES JE=IPIV-1 JK=IPIV DO 9 K=I,IPP1 SUM=0. IF(IRES)5,5,3 3 JK=JK-IRES DO 4 J=JA,JE SUM=SUM+WORK(J)*WORK(JK) 4 JK=JK+1 5 IF(JK-IPIV)6,6,8 6 SUM=WORK(IPIV)-SUM IF(SUM-TOL)12,12,7 7 SUM=SQRT(SUM) WORK(IPIV)=SUM PIV=1./SUM GOTO 9 8 SUM=(WORK(JK)-SUM)*PIV WORK(JK)=SUM 9 JK=JK+K WORK(IEND)=WORK(IEND)-SUM*SUM IRES=IRES+1 IADR=IPIV IF(IOP)10,11,11 10 IF(WORK(IEND)-TEST)13,13,11 11 CONTINUE IF(IOP)12,22,12 12 IF(IOP)14,23,14 13 IER=0 14 IPIV=IRES 15 IF(IPIV)23,23,16 16 SUM=0. JA=ITE+IPIV JJ=IADR JK=IADR K=IPIV DO 19 I=1,IPIV WORK(JK)=(WORK(JA)-SUM)/WORK(JJ) IF(K-1)20,20,17 17 JE=JJ-1 SUM=0. DO 18 J=K,IPIV SUM=SUM+WORK(JK)*WORK(JE) JK=JK+1 18 JE=JE+J JK=JE-IPIV JA=JA-1 JJ=JJ-K 19 K=K-1 20 IF(IOP/2)21,23,21 21 IADR=IADR-IPIV IPIV=IPIV-1 GOTO 15 22 IER=0 23 RETURN END SUBROUTINE APLL(FFCT,N,IP,P,WORK,DATI,IER) DIMENSION P(1),WORK(1),DATI(1),IER(1) IF(N)10,10,1 1 IF(IP)10,10,2 2 IF(N-IP)10,3,3 3 IPP1=IP+1 M=IPP1*(IP+2)/2 IER(1)=0 DO 4 I=1,M 4 WORK(I)=0. DO 8 I=1,N CALL FFCT(I,N,IP,P,DATI,WGT,IER) IF(IER(1))9,5,9 5 J=0 DO 7 K=1,IPP1 AUX=P(K)*WGT DO 6 L=1,K J=J+1 6 WORK(J)=WORK(J)+P(L)*AUX 7 CONTINUE 8 CONTINUE 9 RETURN 10 IER(1)=-1 RETURN END SUBROUTINE APMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) DIMENSION TOP(1),IHE(1),PIV(1),T(1) DOUBLE PRECISION DSUM IER=-1 IF (N-1) 81,81,1 1 IF(M) 81,81,2 2 IER=0 DO 3 I=1,N K=I+N J=K+N TOP(J)=TOP(K) 3 TOP(K)=-TOP(I) L=M+2 LL=L*L DO 4 I=1,LL 4 T(I)=0. K=1 J=L+1 DO 5 I=1,L T(K)=1. 5 K=K+J DO 6 I=1,L K=I+L J=K+L IHE(I)=0 IHE(K)=I 6 IHE(J)=1-I NAN=N+N K=L+L+L J=K+NAN DO 7 I=1,NAN K=K+1 IHE(K)=I J=J+1 7 IHE(J)=I ITER=-1 8 ITER=ITER+1 IF(N+M-ITER) 9,9,10 9 IER=1 GO TO 69 10 ISE=0 IPIV=0 K=L+L+L SAVE=0. DO 14 I=1,NAN IDO=K+I HELP=TOP(I) IF(HELP-SAVE) 12,12,11 11 SAVE=HELP IPIV=I 12 IF(IHE(IDO)) 14,13,14 13 ISE=I 14 CONTINUE IF(IPIV) 69,69,15 15 ILAB=1 IND=0 J=ISE IF(J) 21,21,34 16 K=(K-1)*L DO 17 I=1,L J=L+I K=K+1 17 PIV(J)=T(K) 18 IF(ISE) 22,22,19 19 ISE=-ISE J=L+1 IDO=L+L DO 20 I=J,IDO K=I+L 20 PIV(K)=PIV(I) 21 J=IPIV GO TO 34 22 SAVE=1.E38 IDO=0 K=L+1 LL=L+L IND=0 DO 29 I=K,LL J=I+L HELP=PIV(I) IF(HELP) 29,29,23 23 HELP=-HELP IF(ISE) 26,24,26 24 IF(IHE(J)) 27,25,27 25 IDO=I GO TO 29 26 HELP=-PIV(J)/HELP 27 IF(HELP-SAVE) 28,29,29 28 SAVE=HELP IND=I 29 CONTINUE IF(IND) 30,30,32 30 IF(IDO) 68,68,31 31 IND=IDO 32 REPI=1./PIV(IND) IND=IND-L ILAB=0 SAVE=-TOP(IPIV)*REPI TOP(IPIV)=SAVE J=NAN 33 IF(J-IPIV) 34,53,34 34 K=0 DO 36 I=1,L IF(IHE(I)-J) 36,35,36 35 K=I IF(ILAB) 50,50,16 36 CONTINUE I=L+L+L+NAN+J I=IHE(I)-N IF(I) 37,37,38 37 I=I+N K=1 38 I=I+NAN CALL FCT(PIV,TOP(I),M-1) DSUM=0.D0 IDO=M DO 41 I=1,M HELP=PIV(IDO) IF(K) 39,39,40 39 HELP=-HELP 40 DSUM=DSUM+DBLE(HELP) PIV(IDO+1)=HELP 41 IDO=IDO-1 PIV(L)=-DSUM PIV(1)=1. IDO=IND IF(ILAB) 44,44,42 42 K=1 43 IDO=K 44 DSUM=0.D0 HELP=0. DO 46 I=1,L DSUM=DSUM+DBLE(PIV(I)*T(IDO)) TOL=ABS(SNGL(DSUM)) IF(TOL-HELP) 46,46,45 45 HELP=TOL 46 IDO=IDO+L TOL=1.E-5*HELP IF(ABS(SNGL(DSUM))-TOL) 47,47,48 47 DSUM=0.D0 48 IF(ILAB) 51,51,49 49 I=K+L PIV(I)=DSUM K=K+1 IF(K-L) 43,43,18 50 I=(K-1)*L+IND DSUM=T(I) 51 DSUM=DSUM*DBLE(SAVE) TOL=1.E-5*ABS(SNGL(DSUM)) TOP(J)=TOP(J)+SNGL(DSUM) IF(ABS(TOP(J))-TOL) 52,52,53 52 TOP(J)=0. 53 J=J-1 IF(J) 54,54,33 54 I=IND+L PIV(I)=-1. DO 55 I=1,L J=I+L 55 PIV(I)=-PIV(J)*REPI J=0 DO 57 I=1,L IDO=J+IND SAVE=T(IDO) T(IDO)=0. DO 56 K=1,L ISE=K+J 56 T(ISE)=T(ISE)+SAVE*PIV(K) 57 J=J+L J=0 K=0 ISE=0 IDO=0 DO 61 I=1,L LL=I+L ILAB=IHE(LL) IF(IHE(I)-IPIV) 59,58,59 58 ISE=I J=ILAB 59 IF(ILAB-IND) 61,60,61 60 IDO=I K=IHE(I) 61 CONTINUE IF(K) 62,62,63 62 IHE(IDO)=IPIV IF(ISE) 67,67,65 63 IF(IND-J) 64,66,64 64 LL=L+L+L+NAN K=K+LL I=IPIV+LL ILAB=IHE(K) IHE(K)=IHE(I) IHE(I)=ILAB IF(ISE) 67,67,65 65 IDO=IDO+L I=ISE+L IHE(IDO)=J IHE(I)=IND 66 IHE(ISE)=0 67 LL=L+L J=LL+IND I=LL+L+IPIV ILAB=IHE(I) IHE(I)=IHE(J) IHE(J)=ILAB GO TO 8 68 IER=-1 69 SAVE=0. HELP=0. K=L+L+L DO 73 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 71,70,73 70 SAVE=-TOP(I) 71 IF(M+J+1) 73,72,73 72 HELP=TOP(I) 73 CONTINUE T(1)=SAVE IDO=NAN+1 J=NAN+N DO 74 I=IDO,J 74 TOP(I)=SAVE DO 75 I=1,M 75 PIV(I)=HELP DO 79 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 76,79,77 76 J=-J PIV(J)=HELP-TOP(I) GO TO 79 77 IF(J-N) 78,78,79 78 J=J+NAN TOP(J)=SAVE+TOP(I) 79 CONTINUE DO 80 I=1,N IDO=NAN+I 80 TOP(I)=TOP(IDO) 81 RETURN END SUBROUTINE ARAT(DATI,N,WORK,P,IP,IQ,IER) EXTERNAL FRAT DIMENSION IERV(3) DIMENSION DATI(1),WORK(1),P(1) LIMIT=20 ETA =1.E-11 EPS=1.E-5 IF(N)4,4,1 1 IF(IP)4,4,2 2 IF(IQ)4,4,3 3 IPQ=IP+IQ IF(N-IPQ)4,5,5 4 IER=-1 RETURN 5 KOUNT=0 IERV(2)=IP IERV(3)=IQ NDP=N+N+1 NNE=NDP+NDP IX=IPQ-1 IQP1=IQ+1 IRHS=NNE+IPQ*IX/2 IEND=IRHS+IX IF(IER)8,6,8 6 DO 7 I=2,IPQ 7 P(I)=0. P(1)=1. 8 DO 9 J=1,N T=DATI(J) I=J+N CALL CNPS(WORK(I),T,P(IQP1),IP) K=I+N 9 CALL CNPS(WORK(K),T,P,IQ) 10 CALL APLL(FRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV) IF(IERV(1))4,11,4 11 INCR=0 RELAX=2. 12 J=IEND DO 13 I=NNE,IEND J=J+1 13 WORK(I)=WORK(J) IF(KOUNT)14,14,15 14 OSUM=WORK(IEND) DIAG=OSUM*EPS K=IQ IF(WORK(NNE))17,17,19 15 IF(INCR)19,19,16 16 K=IPQ 17 J=NNE-1 DO 18 I=1,K WORK(J)=WORK(J)+DIAG 18 J=J+I 19 CALL APFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER) IF(IRES)4,4,20 20 IF(IRES-IX)21,24,24 21 IF(INCR)22,22,23 22 DIAG=DIAG*0.125 23 DIAG=DIAG+DIAG INCR=INCR+1 RELAX=8. IF(INCR-LIMIT)12,45,45 24 L=NDP J=NNE+IRES*(IRES-1)/2-1 K=J+IQ WORK(J)=0. IRQ=IQ IRP=IRES-IQ+1 IF(IRP)25,26,26 25 IRQ=IRES+1 26 DO 29 I=1,N T=DATI(I) WORK(I)=0. CALL CNPS(WORK(I),T,WORK(K),IRP) M=L+N CALL CNPS(WORK(M),T,WORK(J),IRQ) IF(WORK(M)*WORK(L))27,29,29 27 SUM=WORK(L)/WORK(M) IF(RELAX+SUM)29,29,28 28 RELAX=-SUM 29 L=L+1 SSOE=OSUM ITER=LIMIT 30 SUM=0. RELAX=RELAX*0.5 DO 32 I=1,N M=I+N K=M+N L=K+N SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L)) SAVE=SAVE*SAVE IF(DATI(NDP))32,32,31 31 SAVE=SAVE*DATI(K) 32 SUM=SUM+SAVE IF(ITER)45,33,33 33 ITER=ITER-1 IF(SUM-OSUM)34,37,35 34 OSUM=SUM GOTO 30 35 IF(OSUM-SSOE)36,30,30 36 RELAX=RELAX+RELAX 37 T=0. SAVE=0. K=IRES+1 DO 38 I=2,K J=J+1 T=T+ABS(P(I)) P(I)=P(I)+RELAX*WORK(J) 38 SAVE=SAVE+ABS(P(I)) DO 39 I=1,N J=I+N K=J+N L=K+N WORK(J)=WORK(J)+RELAX*WORK(I) 39 WORK(K)=WORK(K)+RELAX*WORK(L) IF(INCR)40,40,42 40 IF(SSOE-OSUM-RELAX*EPS*OSUM)46,46,41 41 IF(ABS(T-SAVE)-RELAX*EPS*SAVE)46,46,42 42 IF(OSUM-ETA*SAVE)46,46,43 43 KOUNT=KOUNT+1 IF(KOUNT-LIMIT)10,44,44 44 IER=2 RETURN 45 IER=1 RETURN 46 IER=0 RETURN END SUBROUTINE ARRAY (MODE,I,J,N,M,S,D) DIMENSION S(1),D(1) NI=N-I IF(MODE-1) 100, 100, 120 100 IJ=I*J+1 NM=N*J+1 DO 110 K=1,J NM=NM-NI DO 110 L=1,I IJ=IJ-1 NM=NM-1 110 D(NM)=S(IJ) GO TO 140 120 IJ=0 NM=0 DO 130 K=1,J DO 125 L=1,I IJ=IJ+1 NM=NM+1 125 S(IJ)=D(NM) 130 NM=NM+NI 140 RETURN END SUBROUTINE ATEIG(M,A,RR,RI,IANA,IA) DIMENSION A(1),RR(1),RI(1),PRR(2),PRI(2),IANA(1) INTEGER P,P1,Q E7=1.0E-8 E6=1.0E-6 E10=1.0E-10 DELTA=0.5 MAXIT=30 N=M 20 N1=N-1 IN=N1*IA NN=IN+N IF(N1) 30,1300,30 30 NP=N+1 IT=0 DO 40 I=1,2 PRR(I)=0.0 40 PRI(I)=0.0 PAN=0.0 PAN1=0.0 R=0.0 S=0.0 N2=N1-1 IN1=IN-IA NN1=IN1+N N1N=IN+N1 N1N1=IN1+N1 60 T=A(N1N1)-A(NN) U=T*T V=4.0*A(N1N)*A(NN1) IF(ABS(V)-U*E7) 100,100,65 65 T=U+V IF(ABS(T)-AMAX1(U,ABS(V))*E6) 67,67,68 67 T=0.0 68 U=(A(N1N1)+A(NN))/2.0 V=SQRT(ABS(T))/2.0 IF(T)140,70,70 70 IF(U) 80,75,75 75 RR(N1)=U+V RR(N)=U-V GO TO 130 80 RR(N1)=U-V RR(N)=U+V GO TO 130 100 IF(T)120,110,110 110 RR(N1)=A(N1N1) RR(N)=A(NN) GO TO 130 120 RR(N1)=A(NN) RR(N)=A(N1N1) 130 RI(N)=0.0 RI(N1)=0.0 GO TO 160 140 RR(N1)=U RR(N)=U RI(N1)=V RI(N)=-V 160 IF(N2)1280,1280,180 180 N1N2=N1N1-IA RMOD=RR(N1)*RR(N1)+RI(N1)*RI(N1) EPS=E10*SQRT(RMOD) IF(ABS(A(N1N2))-EPS)1280,1280,240 240 IF(ABS(A(NN1))-E10*ABS(A(NN))) 1300,1300,250 250 IF(ABS(PAN1-A(N1N2))-ABS(A(N1N2))*E6) 1240,1240,260 260 IF(ABS(PAN-A(NN1))-ABS(A(NN1))*E6)1240,1240,300 300 IF(IT-MAXIT) 320,1240,1240 320 J=1 DO 360 I=1,2 K=NP-I IF(ABS(RR(K)-PRR(I))+ABS(RI(K)-PRI(I))-DELTA*(ABS(RR(K)) 1 +ABS(RI(K)))) 340,360,360 340 J=J+I 360 CONTINUE GO TO (440,460,460,480),J 440 R=0.0 S=0.0 GO TO 500 460 J=N+2-J R=RR(J)*RR(J) S=RR(J)+RR(J) GO TO 500 480 R=RR(N)*RR(N1)-RI(N)*RI(N1) S=RR(N)+RR(N1) 500 PAN=A(NN1) PAN1=A(N1N2) DO 520 I=1,2 K=NP-I PRR(I)=RR(K) 520 PRI(I)=RI(K) P=N2 IF (N-3)600,600,525 525 IPI=N1N2 DO 580 J=2,N2 IPI=IPI-IA-1 IF(ABS(A(IPI))-EPS) 600,600,530 530 IPIP=IPI+IA IPIP2=IPIP+IA D=A(IPIP)*(A(IPIP)-S)+A(IPIP2)*A(IPIP+1)+R IF(D)540,560,540 540 IF(ABS(A(IPI)*A(IPIP+1))*(ABS(A(IPIP)+A(IPIP2+1)-S)+ABS(A(IPIP2+2) 1 )) -ABS(D)*EPS) 620,620,560 560 P=N1-J 580 CONTINUE 600 Q=P GO TO 680 620 P1=P-1 Q=P1 IF (P1-1) 680,680,650 650 DO 660 I=2, P1 IPI=IPI-IA-1 IF(ABS(A(IPI))-EPS)680,680,660 660 Q=Q-1 680 II=(P-1)*IA+P DO 1220 I=P,N1 II1=II-IA IIP=II+IA IF(I-P)720,700,720 700 IPI=II+1 IPIP=IIP+1 G1=A(II)*(A(II)-S)+A(IIP)*A(IPI)+R G2=A(IPI)*(A(IPIP)+A(II)-S) G3=A(IPI)*A(IPIP+1) A(IPI+1)=0.0 GO TO 780 720 G1=A(II1) G2=A(II1+1) IF(I-N2)740,740,760 740 G3=A(II1+2) GO TO 780 760 G3=0.0 780 CAP=SQRT(G1*G1+G2*G2+G3*G3) IF(CAP)800,860,800 800 IF(G1)820,840,840 820 CAP=-CAP 840 T=G1+CAP PSI1=G2/T PSI2=G3/T ALPHA=2.0/(1.0+PSI1*PSI1+PSI2*PSI2) GO TO 880 860 ALPHA=2.0 PSI1=0.0 PSI2=0.0 880 IF(I-Q)900,960,900 900 IF(I-P)920,940,920 920 A(II1)=-CAP GO TO 960 940 A(II1)=-A(II1) 960 IJ=II DO 1040 J=I,N T=PSI1*A(IJ+1) IF(I-N1)980,1000,1000 980 IP2J=IJ+2 T=T+PSI2*A(IP2J) 1000 ETA=ALPHA*(T+A(IJ)) A(IJ)=A(IJ)-ETA A(IJ+1)=A(IJ+1)-PSI1*ETA IF(I-N1)1020,1040,1040 1020 A(IP2J)=A(IP2J)-PSI2*ETA 1040 IJ=IJ+IA IF(I-N1)1080,1060,1060 1060 K=N GO TO 1100 1080 K=I+2 1100 IP=IIP-I DO 1180 J=Q,K JIP=IP+J JI=JIP-IA T=PSI1*A(JIP) IF(I-N1)1120,1140,1140 1120 JIP2=JIP+IA T=T+PSI2*A(JIP2) 1140 ETA=ALPHA*(T+A(JI)) A(JI)=A(JI)-ETA A(JIP)=A(JIP)-ETA*PSI1 IF(I-N1)1160,1180,1180 1160 A(JIP2)=A(JIP2)-ETA*PSI2 1180 CONTINUE IF(I-N2)1200,1220,1220 1200 JI=II+3 JIP=JI+IA JIP2=JIP+IA ETA=ALPHA*PSI2*A(JIP2) A(JI)=-ETA A(JIP)=-ETA*PSI1 A(JIP2)=A(JIP2)-ETA*PSI2 1220 II=IIP+1 IT=IT+1 GO TO 60 1240 IF(ABS(A(NN1))-ABS(A(N1N2))) 1300,1280,1280 1280 IANA(N)=0 IANA(N1)=2 N=N2 IF(N2)1400,1400,20 1300 RR(N)=A(NN) RI(N)=0.0 IANA(N)=1 IF(N1)1400,1400,1320 1320 N=N1 GO TO 20 1400 RETURN END SUBROUTINE ATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) DIMENSION F(1),ARG(1),VAL(1) IF(IROW-1)19,17,1 1 IF(DZ)2,17,2 2 N=NDIM IF(N-IROW)4,4,3 3 N=IROW 4 J=(X-ZS)/DZ+1.5 IF(J)5,5,6 5 J=1 6 IF(J-IROW)8,8,7 7 J=IROW 8 II=J JL=0 JR=0 DO 16 I=1,N ARG(I)=ZS+FLOAT(II-1)*DZ IF(ICOL-2)9,10,10 9 VAL(I)=F(II) GOTO 11 10 VAL(2*I-1)=F(II) III=II+IROW VAL(2*I)=F(III) 11 IF(J+JR-IROW)12,15,12 12 IF(J-JL-1)13,14,13 13 IF((ARG(I)-X)*DZ)14,15,15 14 JR=JR+1 II=J+JR GOTO 16 15 JL=JL+1 II=J-JL 16 CONTINUE RETURN 17 ARG(1)=ZS VAL(1)=F(1) IF(ICOL-2)19,19,18 18 VAL(2)=F(2) 19 RETURN END SUBROUTINE ATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1) IF(IROW)11,11,1 1 N=NDIM IF(N-IROW)3,3,2 2 N=IROW 3 B=0. DO 5 I=1,IROW DELTA=ABS(Z(I)-X) IF(DELTA-B)5,5,4 4 B=DELTA 5 WORK(I)=DELTA B=B+1. DO 10 J=1,N DELTA=B DO 7 I=1,IROW IF(WORK(I)-DELTA)6,7,7 6 II=I DELTA=WORK(I) 7 CONTINUE ARG(J)=Z(II) IF(ICOL-1)8,9,8 8 VAL(2*J-1)=F(II) III=II+IROW VAL(2*J)=F(III) GOTO 10 9 VAL(J)=F(II) 10 WORK(II)=B 11 RETURN END SUBROUTINE ATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM) DIMENSION Z(1),F(1),ARG(1),VAL(1) IF(IROW-1)23,21,1 1 N=NDIM IF(N-IROW)3,3,2 2 N=IROW 3 IF(Z(IROW)-Z(1))5,4,4 4 J=IROW I=1 GOTO 6 5 I=IROW J=1 6 K=(J+I)/2 IF(X-Z(K))7,7,8 7 J=K GOTO 9 8 I=K 9 IF(IABS(J-I)-1)10,10,6 10 IF(ABS(Z(J)-X)-ABS(Z(I)-X))12,12,11 11 J=I 12 K=J JL=0 JR=0 DO 20 I=1,N ARG(I)=Z(K) IF(ICOL-1)14,14,13 13 VAL(2*I-1)=F(K) KK=K+IROW VAL(2*I)=F(KK) GOTO 15 14 VAL(I)=F(K) 15 JJR=J+JR IF(JJR-IROW)16,18,18 16 JJL=J-JL IF(JJL-1)19,19,17 17 IF(ABS(Z(JJR+1)-X)-ABS(Z(JJL-1)-X))19,19,18 18 JL=JL+1 K=J-JL GOTO 20 19 JR=JR+1 K=J+JR 20 CONTINUE RETURN 21 ARG(1)=Z(1) VAL(1)=F(1) IF(ICOL-2)23,22,23 22 VAL(2)=F(2) 23 RETURN END SUBROUTINE AUTO (A,N,L,R) DIMENSION A(1),R(1) AVER=0.0 IF(N-L) 50,50,100 50 R(1)=0.0 RETURN 100 DO 110 I=1,N 110 AVER=AVER+A(I) FN=N AVER=AVER/FN DO 130 J=1,L NJ=N-J+1 SUM=0.0 DO 120 I=1,NJ IJ=I+J-1 120 SUM=SUM+(A(I)-AVER)*(A(IJ)-AVER) FNJ=NJ 130 R(J)=SUM/FNJ RETURN END SUBROUTINE AVCAL (K,LEVEL,X,L,ISTEP,LASTS) DIMENSION LEVEL(1),X(1),ISTEP(1),LASTS(1) LASTS(1)=L+1 DO 145 I=2,K 145 LASTS(I)=LASTS(I-1)+ISTEP(I) 150 DO 175 I=1,K L=1 LL=1 SUM=0.0 NN=LEVEL(I) FN=NN INCRE=ISTEP(I) LAST=LASTS(I) 155 DO 160 J=1,NN SUM=SUM+X(L) 160 L=L+INCRE X(L)=SUM DO 165 J=1,NN X(LL)=FN*X(LL)-SUM 165 LL=LL+INCRE SUM=0.0 IF(L-LAST) 167, 175, 175 167 IF(L-LAST+INCRE) 168, 168, 170 168 L=L+INCRE LL=LL+INCRE GO TO 155 170 L=L+INCRE+1-LAST LL=LL+INCRE+1-LAST GO TO 155 175 CONTINUE RETURN END SUBROUTINE AVDAT (K,LEVEL,N,X,L,ISTEP,KOUNT) DIMENSION LEVEL(1),X(1),ISTEP(1),KOUNT(1) M=LEVEL(1)+1 DO 105 I=2,K 105 M=M*(LEVEL(I)+1) N1=M+1 N2=N+1 DO 107 I=1,N N1=N1-1 N2=N2-1 107 X(N1)=X(N2) ISTEP(1)=1 DO 110 I=2,K 110 ISTEP(I)=ISTEP(I-1)*(LEVEL(I-1)+1) DO 115 I=1,K 115 KOUNT(I)=1 N1=N1-1 DO 135 I=1,N L=KOUNT(1) DO 120 J=2,K 120 L=L+ISTEP(J)*(KOUNT(J)-1) N1=N1+1 X(L)=X(N1) DO 130 J=1,K IF(KOUNT(J)-LEVEL(J)) 124, 125, 124 124 KOUNT(J)=KOUNT(J)+1 GO TO 135 125 KOUNT(J)=1 130 CONTINUE 135 CONTINUE RETURN END SUBROUTINE BDTR(X,A,B,P,D,IER) DOUBLE PRECISION XX,DLXX,DL1X,AA,BB,G1,G2,G3,G4,DD,PP,XO,FF,FN, 1XI,SS,CC,RR,DLBETA IF(A-(.5-1.E-5)) 640,10,10 10 IF(B-(.5-1.E-5)) 640,20,20 20 IF(A-1.E+5) 30,30,640 30 IF(B-1.E+5) 40,40,640 40 IF(X) 640,50,50 50 IF(1.-X) 640,60,60 60 AA=DBLE(A) BB=DBLE(B) CALL DLGAM(AA,G1,IOK) CALL DLGAM(BB,G2,IOK) CALL DLGAM(AA+BB,G3,IOK) DLBETA=G1+G2-G3 IF(X-1.E-8) 80,80,70 70 IF((1.-X)-1.E-8) 130,130,140 80 P=0.0 IF(A-1.) 90,100,120 90 D=1.E+33 GO TO 660 100 DD=-DLBETA IF(DD+1.68D02) 120,120,110 110 DD=DEXP(DD) D=SNGL(DD) GO TO 660 120 D=0.0 GO TO 660 130 P=1.0 IF(B-1.) 90,100,120 140 XX=DBLE(X) DLXX=DLOG(XX) DL1X=DLOG(1.D0-XX) XO=XX/(1.D0-XX) ID=0 DD=(AA-1.D0)*DLXX+(BB-1.D0)*DL1X-DLBETA IF(DD-1.68D02) 150,150,160 150 IF(DD+1.68D02) 170,170,180 160 D=1.E33 GO TO 190 170 D=0.0 GO TO 190 180 DD=DEXP(DD) D=SNGL(DD) 190 IF(ABS(A-1.)-1.E-8) 200,200,210 200 IF(ABS(B-1.)-1.E-8) 220,220,230 210 IF(ABS(B-1.)-1.E-8) 260,260,290 220 P=X GO TO 660 230 PP=BB*DL1X IF(PP+1.68D02) 240,240,250 240 P=1.0 GO TO 660 250 PP=DEXP(PP) PP=1.D0-PP P=SNGL(PP) GO TO 600 260 PP=AA*DLXX IF(PP+1.68D02) 270,270,280 270 P=0.0 GO TO 660 280 PP=DEXP(PP) P=SNGL(PP) GO TO 600 290 IF(A-1000.) 300,300,310 300 IF(B-1000.) 330,330,320 310 XX=2.D0*AA/XO XS=SNGL(XX) AA=2.D0*BB DF=SNGL(AA) CALL CDTR(XS,DF,P,DUMMY,IER) P=1.0-P GO TO 670 320 XX=2.D0*BB*XO XS=SNGL(XX) AA=2.D0*AA DF=SNGL(AA) CALL CDTR(XS,DF,P,DUMMY,IER) GO TO 670 330 IF(X-.5) 340,340,380 340 IF(AA-1.D0) 350,350,360 350 RR=AA+1.D0 GO TO 370 360 RR=AA 370 DD=DLXX/5.D0 DD=DEXP(DD) DD=(RR-1.D0)-(RR+BB-1.D0)*XX*DD +2.D0 IF(DD) 420,420,430 380 IF(BB-1.D0) 390,390,400 390 RR=BB+1.D0 GO TO 410 400 RR=BB 410 DD=DL1X/5.D0 DD=DEXP(DD) DD=(RR-1.D0)-(AA+RR-1.D0)*(1.D0-XX)*DD +2.D0 IF(DD) 430,430,420 420 ID=1 FF=DL1X DL1X=DLXX DLXX=FF XO=1.D0/XO FF=AA AA=BB BB=FF G2=G1 430 FF=0.D0 IF(AA-1.D0) 440,440,470 440 CALL DLGAM(AA+1.D0,G4,IOK) DD=AA*DLXX+BB*DL1X+G3-G2-G4 IF(DD+1.68D02) 460,460,450 450 FF=FF+DEXP(DD) 460 AA=AA+1.D0 470 FN=AA+BB-1.D0 RR=AA-1.D0 II=80 XI=DFLOAT(II) SS=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI)) SS=SS*XO DO 480 I=1,79 II=80-I XI=DFLOAT(II) DD=(XI*(FN+XI))/((RR+2.D0*XI+1.D0)*(RR+2.D0*XI)) DD=DD*XO CC=((BB-XI)*(RR+XI))/((RR+2.D0*XI-1.D0)*(RR+2.D0*XI)) CC=CC*XO SS=CC/(1.D0+DD/(1.D0-SS)) 480 CONTINUE SS=1.D0/(1.D0-SS) IF(SS) 650,650,490 490 CALL DLGAM(AA+BB,G1,IOK) CALL DLGAM(AA+1.D0,G4,IOK) CC=G1-G2-G4+AA*DLXX+(BB-1.D0)*DL1X PP=CC+DLOG(SS) IF(PP+1.68D02) 500,500,510 500 PP=FF GO TO 520 510 PP=DEXP(PP)+FF 520 IF(ID) 540,540,530 530 PP=1.D0-PP 540 P=SNGL(PP) IF(P) 550,570,570 550 IF(ABS(P)-1.E-7) 560,560,650 560 P=0.0 GO TO 660 570 IF(1.-P) 580,600,600 580 IF(ABS(1.-P)-1.E-7) 590,590,650 590 P=1.0 GO TO 660 600 IF(P-1.E-8) 610,610,620 610 P=0.0 GO TO 660 620 IF((1.0-P)-1.E-8) 630,630,660 630 P=1.0 GO TO 660 640 IER=-2 D=-1.E33 P=-1.E33 GO TO 670 650 IER=+2 P= 1.E33 GO TO 670 660 IER=0 670 RETURN END SUBROUTINE BESJ(X,N,BJ,D,IER) BJ=.0 IF(N)10,20,20 10 IER=1 RETURN 20 IF(X)30,30,31 30 IER=2 RETURN 31 IF(X-15.)32,32,34 32 NTEST=20.+10.*X-X** 2/3 GO TO 36 34 NTEST=90.+X/2. 36 IF(N-NTEST)40,38,38 38 IER=4 RETURN 40 IER=0 N1=N+1 BPREV=.0 IF(X-5.)50,60,60 50 MA=X+6. GO TO 70 60 MA=1.4*X+60./X 70 MB=N+IFIX(X)/4+2 MZERO=MAX0(MA,MB) MMAX=NTEST 100 DO 190 M=MZERO,MMAX,3 FM1=1.0E-28 FM=.0 ALPHA=.0 IF(M-(M/2)*2)120,110,120 110 JT=-1 GO TO 130 120 JT=1 130 M2=M-2 DO 160 K=1,M2 MK=M-K BMK=2.*FLOAT(MK)*FM1/X-FM FM=FM1 FM1=BMK IF(MK-N-1)150,140,150 140 BJ=BMK 150 JT=-JT S=1+JT 160 ALPHA=ALPHA+BMK*S BMK=2.*FM1/X-FM IF(N)180,170,180 170 BJ=BMK 180 ALPHA=ALPHA+BMK BJ=BJ/ALPHA IF(ABS(BJ-BPREV)-ABS(D*BJ))200,200,190 190 BPREV=BJ IER=3 200 RETURN END SUBROUTINE BESK(X,N,BK,IER) DIMENSION T(12) BK=.0 IF(N)10,11,11 10 IER=1 RETURN 11 IF(X)12,12,20 12 IER=2 RETURN 20 IF(X-170.0)22,22,21 21 IER=3 RETURN 22 IER=0 IF(X-1.)36,36,25 25 A=EXP(-X) B=1./X C=SQRT(B) T(1)=B DO 26 L=2,12 26 T(L)=T(L-1)*B IF(N-1)27,29,27 27 G0=A*(1.2533141-.1566642*T(1)+.08811128*T(2)-.09139095*T(3) 2+.1344596*T(4)-.2299850*T(5)+.3792410*T(6)-.5247277*T(7) 3+.5533368*T(8)-.4262633*T(9)+.2184518*T(10)-.06680977*T(11) 4+.009189383*T(12))*C IF(N)20,28,29 28 BK=G0 RETURN 29 G1=A*(1.2533141+.4699927*T(1)-.1468583*T(2)+.1280427*T(3) 2-.1736432*T(4)+.2847618*T(5)-.4594342*T(6)+.6283381*T(7) 3-.6632295*T(8)+.5050239*T(9)-.2581304*T(10)+.07880001*T(11) 4-.01082418*T(12))*C IF(N-1)20,30,31 30 BK=G1 RETURN 31 DO 35 J=2,N GJ=2.*(FLOAT(J)-1.)*G1/X+G0 IF(GJ-1.0E33)33,33,32 32 IER=4 GO TO 34 33 G0=G1 35 G1=GJ 34 BK=GJ RETURN 36 B=X/2. A=.5772157+ALOG(B) C=B*B IF(N-1)37,43,37 37 G0=-A X2J=1. FACT=1. HJ=.0 DO 40 J=1,6 RJ=1./FLOAT(J) X2J=X2J*C FACT=FACT*RJ*RJ HJ=HJ+RJ 40 G0=G0+X2J*FACT*(HJ-A) IF(N)43,42,43 42 BK=G0 RETURN 43 X2J=B FACT=1. HJ=1. G1=1./X+X2J*(.5+A-HJ) DO 50 J=2,8 X2J=X2J*C RJ=1./FLOAT(J) FACT=FACT*RJ*RJ HJ=HJ+RJ 50 G1=G1+X2J*FACT*(.5+(A-HJ)*FLOAT(J)) IF(N-1)31,52,31 52 BK=G1 RETURN END SUBROUTINE BESY(X,N,BY,IER) IF(N)180,10,10 10 IER=0 IF(X)190,190,20 20 IF(X-4.0)40,40,30 30 T1=4.0/X T2=T1*T1 P0=((((-.0000037043*T2+.0000173565)*T2-.0000487613)*T2 1 +.00017343)*T2-.001753062)*T2+.3989423 Q0=((((.0000032312*T2-.0000142078)*T2+.0000342468)*T2 1 -.0000869791)*T2+.0004564324)*T2-.01246694 P1=((((.0000042414*T2-.0000200920)*T2+.0000580759)*T2 1 -.000223203)*T2+.002921826)*T2+.3989423 Q1=((((-.0000036594*T2+.00001622)*T2-.0000398708)*T2 1 +.0001064741)*T2-.0006390400)*T2+.03740084 A=2.0/SQRT(X) B=A*T1 C=X-.7853982 Y0=A*P0*SIN(C)+B*Q0*COS(C) Y1=-A*P1*COS(C)+B*Q1*SIN(C) GO TO 90 40 XX=X/2. X2=XX*XX T=ALOG(XX)+.5772157 SUM=0. TERM=T Y0=T DO 70 L=1,15 IF(L-1)50,60,50 50 SUM=SUM+1./FLOAT(L-1) 60 FL=L TS=T-SUM TERM=(TERM*(-X2)/FL**2)*(1.-1./(FL*TS)) 70 Y0=Y0+TERM TERM = XX*(T-.5) SUM=0. Y1=TERM DO 80 L=2,16 SUM=SUM+1./FLOAT(L-1) FL=L FL1=FL-1. TS=T-SUM TERM=(TERM*(-X2)/(FL1*FL))*((TS-.5/FL)/(TS+.5/FL1)) 80 Y1=Y1+TERM PI2=.6366198 Y0=PI2*Y0 Y1=-PI2/X+PI2*Y1 90 IF(N-1)100,100,130 100 IF(N)110,120,110 110 BY=Y1 GO TO 170 120 BY=Y0 GO TO 170 130 YA=Y0 YB=Y1 K=1 140 T=FLOAT(2*K)/X YC=T*YB-YA IF(ABS(YC)-1.0E33)145,145,141 141 IER=3 RETURN 145 K=K+1 IF(K-N)150,160,150 150 YA=YB YB=YC GO TO 140 160 BY=YC 170 RETURN 180 IER=1 RETURN 190 IER=2 RETURN END SUBROUTINE BISER (N,A,B,HI,ANS,IER) DIMENSION A(1),B(1),ANS(1) IER=0 SUM=0.0 SUM2=0.0 DO 10 I=1,N SUM=SUM+A(I) 10 SUM2=SUM2+A(I)*A(I) FN=N ANS(1)=SUM/FN ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0) ANS(2)= SQRT(ANS(2)) P=0.0 SUM=0.0 SUM2=0.0 DO 30 I=1,N IF(B(I)-HI) 20, 25, 25 20 SUM2=SUM2+A(I) GO TO 30 25 P=P+1.0 SUM=SUM+A(I) 30 CONTINUE ANS(4)=1.0 ANS(3)=0.0 Q=FN-P IF (P) 35,35,40 35 IER=-1 GO TO 50 40 ANS(5)=SUM/P IF (Q) 45,45,60 45 IER=1 ANS(4)=0.0 ANS(3)=1.0 50 DO 55 I=5,8 55 ANS(I)=1.E33 GO TO 65 60 ANS(6)=SUM2/Q P=P/FN Q=1.0-P CALL NDTRI (Q,X,Y,ER) R=((ANS(5)-ANS(1))/ANS(2))*(P/Y) ANS(8)=( SQRT(P*Q)/Y-R*R)/SQRT(FN) ANS(3)=P ANS(4)=Q ANS(7)=R 65 RETURN END SUBROUTINE BOUND(A,S,BLO,BHI,UNDER,BETW,OVER,NO,NV) DIMENSION A(1),S(1),BLO(1),BHI(1),UNDER(1),BETW(1),OVER(1) IER=0 DO 10 I=1,NV IF (BLO(I)-BHI(I)) 10,10,11 11 IER=1 GO TO 12 10 CONTINUE DO 1 K=1,NV UNDER(K)=0.0 BETW(K)=0.0 1 OVER(K)=0.0 DO 8 J=1,NO IJ=J-NO IF(S(J)) 2,8,2 2 DO 7 I=1,NV IJ=IJ+NO IF(A(IJ)-BLO(I)) 5,3,3 3 IF(A(IJ)-BHI(I)) 4,4,6 4 BETW(I)=BETW(I)+1.0 GO TO 7 5 UNDER(I)=UNDER(I)+1.0 GO TO 7 6 OVER(I)=OVER(I)+1.0 7 CONTINUE 8 CONTINUE 12 RETURN END SUBROUTINE CADD(A,ICA,R,ICR,N,M,MS,L) DIMENSION A(1),R(1) IR=N*(ICR-1) DO 2 I=1,N IR=IR+1 CALL LOC(I,ICA,IA,N,M,MS) IF(IA) 1,2,1 1 R(IR)=R(IR)+A(IA) 2 CONTINUE RETURN END SUBROUTINE CANOR (N,MP,MQ,RR,ROOTS,WLAM,CANR,CHISQ,NDF,COEFR, 1 COEFL,R) DIMENSION RR(1),ROOTS(1),WLAM(1),CANR(1),CHISQ(1),NDF(1),COEFR(1), 1 COEFL(1),R(1) M=MP+MQ N1=0 DO 105 I=1,M DO 105 J=1,M IF(I-J) 102, 103, 103 102 L=I+(J*J-J)/2 GO TO 104 103 L=J+(I*I-I)/2 104 N1=N1+1 105 R(N1)=RR(L) L=MP DO 108 J=2,MP N1=M*(J-1) DO 108 I=1,MP L=L+1 N1=N1+1 108 R(L)=R(N1) N2=MP+1 L=0 DO 110 J=N2,M N1=M*(J-1) DO 110 I=1,MP L=L+1 N1=N1+1 110 COEFL(L)=R(N1) L=0 DO 120 J=N2,M N1=M*(J-1)+MP DO 120 I=N2,M L=L+1 N1=N1+1 120 COEFR(L)=R(N1) L=MP*MP+1 K=L+MP CALL MINV (R,MP,DET,R(L),R(K)) DO 140 I=1,MP N2=0 DO 130 J=1,MQ N1=I-MP ROOTS(J)=0.0 DO 130 K=1,MP N1=N1+MP N2=N2+1 130 ROOTS(J)=ROOTS(J)+R(N1)*COEFL(N2) L=I-MP DO 140 J=1,MQ L=L+MP 140 R(L)=ROOTS(J) L=MP*MQ N3=L+1 DO 160 J=1,MQ N1=0 DO 160 I=1,MQ N2=MP*(J-1) SUM=0.0 DO 150 K=1,MP N1=N1+1 N2=N2+1 150 SUM=SUM+COEFL(N1)*R(N2) L=L+1 160 R(L)=SUM L=L+1 CALL NROOT (MQ,R(N3),COEFR,ROOTS,R(L)) DO 210 I=1,MQ IF(ROOTS(I)) 220, 220, 165 165 CANR(I)= SQRT(ROOTS(I)) WLAM(I)=1.0 DO 170 J=I,MQ 170 WLAM(I)=WLAM(I)*(1.0-ROOTS(J)) FN=N FMP=MP FMQ=MQ 175 CHISQ(I)=-(FN-0.5*(FMP+FMQ+1.0))*ALOG(WLAM(I)) N1=I-1 NDF(I)=(MP-N1)*(MQ-N1) N1=MQ*(I-1) N2=MQ*(I-1)+L-1 DO 180 J=1,MQ N1=N1+1 N2=N2+1 180 COEFR(N1)=R(N2) DO 200 J=1,MP N1=J-MP N2=MQ*(I-1) K=MP*(I-1)+J COEFL(K)=0.0 DO 190 JJ=1,MQ N1=N1+MP N2=N2+1 190 COEFL(K)=COEFL(K)+R(N1)*COEFR(N2) 200 COEFL(K)=COEFL(K)/CANR(I) 210 CONTINUE 220 RETURN END SUBROUTINE CCPY(A,L,R,N,M,MS) DIMENSION A(1),R(1) DO 3 I=1,N CALL LOC(I,L,IL,N,M,MS) IF(IL) 1,2,1 1 R(I)=A(IL) GO TO 3 2 R(I)=0.0 3 CONTINUE RETURN END SUBROUTINE CCUT(A,L,R,S,N,M,MS) DIMENSION A(1),R(1),S(1) IR=0 IS=0 DO 70 J=1,M DO 70 I=1,N IF(J-L) 20,10,10 10 IS=IS+1 S(IS)=0.0 GO TO 30 20 IR=IR+1 R(IR)=0.0 30 CALL LOC(I,J,IJ,N,M,MS) IF(IJ) 40,70,40 40 IF(J-L) 60,50,50 50 S(IS)=A(IJ) GO TO 70 60 R(IR)=A(IJ) 70 CONTINUE RETURN END SUBROUTINE CDTR(X,G,P,D,IER) DOUBLE PRECISION XX,DLXX,X2,DLX2,GG,G2,DLT3,THETA,THP1, 1GLG2,DD,T11,SER,CC,XI,FAC,TLOG,TERM,GTH,A2,A,B,C,DT2,DT3,THPI IF(G-(.5-1.E-5)) 590,10,10 10 IF(G-2.E+5) 20,20,590 20 IF(X) 590,30,30 30 IF(X-1.E-8) 40,40,80 40 P=0.0 IF(G-2.) 50,60,70 50 D=1.E33 GO TO 610 60 D=0.5 GO TO 610 70 D=0.0 GO TO 610 80 IF(X-1.E+6) 100,100,90 90 D=0.0 P=1.0 GO TO 610 100 XX=DBLE(X) DLXX=DLOG(XX) X2=XX/2.D0 DLX2=DLOG(X2) GG=DBLE(G) G2=GG/2.D0 CALL DLGAM(G2,GLG2,IOK) DD=(G2-1.D0)*DLXX-X2-G2*.6931471805599453 -GLG2 IF(DD-1.68D02) 110,110,120 110 IF(DD+1.68D02) 130,130,140 120 D=1.E33 GO TO 150 130 D=0.0 GO TO 150 140 DD=DEXP(DD) D=SNGL(DD) 150 IF(G-1000.) 160,160,180 160 IF(X-2000.) 190,190,170 170 P=1.0 GO TO 610 180 A=DLOG(XX/GG)/3.D0 A=DEXP(A) B=2.D0/(9.D0*GG) C=(A-1.D0+B)/DSQRT(B) SC=SNGL(C) CALL NDTR(SC,P,DUMMY) GO TO 490 190 K= IDINT(G2) THETA=G2-DFLOAT(K) IF(THETA-1.D-8) 200,200,210 200 THETA=0.D0 210 THP1=THETA+1.D0 IF(THETA) 230,230,220 220 IF(XX-10.D0) 260,260,320 230 IF(X2-1.68D02) 250,240,240 240 T1=1.0 GO TO 400 250 T11=1.D0-DEXP(-X2) T1=SNGL(T11) GO TO 400 260 SER=X2*(1.D0/THP1 -X2/(THP1+1.D0)) J=+1 CC=DFLOAT(J) DO 270 IT1=3,30 XI=DFLOAT(IT1) CALL DLGAM(XI,FAC,IOK) TLOG= XI*DLX2-FAC-DLOG(XI+THETA) TERM=DEXP(TLOG) TERM=DSIGN(TERM,CC) SER=SER+TERM CC=-CC IF(DABS(TERM)-1.D-9) 280,270,270 270 CONTINUE GO TO 600 280 IF(SER) 600,600,290 290 CALL DLGAM(THP1,GTH,IOK) TLOG=THETA*DLX2+DLOG(SER)-GTH IF(TLOG+1.68D02) 300,300,310 300 T1=0.0 GO TO 400 310 T11=DEXP(TLOG) T1=SNGL(T11) GO TO 400 320 A2=0.D0 DO 340 I=1,25 XI=DFLOAT(I) CALL DLGAM(THP1,GTH,IOK) T11=-(13.D0*XX)/XI +THP1*DLOG(13.D0*XX/XI) -GTH-DLOG(XI) IF(T11+1.68D02) 340,340,330 330 T11=DEXP(T11) A2=A2+T11 340 CONTINUE A=1.01282051+THETA/156.D0-XX/312.D0 B=DABS(A) C= -X2+THP1*DLX2+DLOG(B)-GTH-3.951243718581427 IF(C+1.68D02) 370,370,350 350 IF (A) 360,370,380 360 C=-DEXP(C) GO TO 390 370 C=0.D0 GO TO 390 380 C=DEXP(C) 390 C=A2+C T11=1.D0-C T1=SNGL(T11) 400 IF(G-2.) 420,410,410 410 IF(G-4.) 450,460,460 420 CALL DLGAM(THP1,GTH,IOK) DT2=THETA*DLXX-X2-THP1*.6931471805599453 -GTH IF(DT2+1.68D02) 430,430,440 430 P=T1 GO TO 490 440 DT2=DEXP(DT2) T2=SNGL(DT2) P=T1+T2+T2 GO TO 490 450 P=T1 GO TO 490 460 DT3=0.D0 DO 480 I3=2,K THPI=DFLOAT(I3)+THETA CALL DLGAM(THPI,GTH,IOK) DLT3=THPI*DLX2-DLXX-X2-GTH IF(DLT3+1.68D02) 480,480,470 470 DT3=DT3+DEXP(DLT3) 480 CONTINUE T3=SNGL(DT3) P=T1-T3-T3 490 IF(P) 500,520,520 500 IF(ABS(P)-1.E-7) 510,510,600 510 P=0.0 GO TO 610 520 IF(1.-P) 530,550,550 530 IF(ABS(1.-P)-1.E-7) 540,540,600 540 P=1.0 GO TO 610 550 IF(P-1.E-8) 560,560,570 560 P=0.0 GO TO 610 570 IF((1.0-P)-1.E-8) 580,580,610 580 P=1.0 GO TO 610 590 IER=-1 D=-1.E33 P=-1.E33 GO TO 620 600 IER=+1 P= 1.E33 GO TO 620 610 IER=0 620 RETURN END SUBROUTINE CEL1(RES,AK,IER) IER=0 ARI=2. GEO=(0.5-AK)+0.5 GEO=GEO+GEO*AK RES=0.5 IF(GEO)1,2,4 1 IER=1 2 RES=1.E33 RETURN 3 GEO=GEO*AARI 4 GEO=SQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO RES=RES+RES IF(GEO/AARI-0.9999)3,5,5 5 RES=RES/ARI*6.283185E0 RETURN END SUBROUTINE CEL2(RES,AK,A,B,IER) IER=0 ARI=2. GEO=(0.5-AK)+0.5 GEO=GEO+GEO*AK RES=A A1=A+B B0=B+B IF(GEO)1,2,6 1 IER=1 2 IF(B)3,8,4 3 RES=-1.E33 RETURN 4 RES=1.E33 RETURN 5 GEO=GEO*AARI 6 GEO=SQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO B0=B0+RES*GEO RES=A1 B0=B0+B0 A1=B0/ARI+A1 IF(GEO/AARI-0.9999)5,7,7 7 RES=A1/ARI RES=RES+0.5707963E0*RES 8 RETURN END SUBROUTINE CHISQ(A,N,M,CS,NDF,IERR,TR,TC) DIMENSION A(1),TR(1),TC(1) NM=N*M IERR=0 CS=0.0 NDF=(N-1)*(M-1) IF(NDF) 5,5,10 5 IERR=3 RETURN 10 DO 90 I=1,N TR(I)=0.0 IJ=I-N DO 90 J=1,M IJ=IJ+N 90 TR(I)=TR(I)+A(IJ) IJ=0 DO 100 J=1,M TC(J)=0.0 DO 100 I=1,N IJ=IJ+1 100 TC(J)=TC(J)+A(IJ) GT=0.0 DO 110 I=1,N 110 GT=GT+TR(I) IF(NM-4) 130,120,130 120 CS=GT*(ABS(A(1)*A(4)-A(2)*A(3))-GT/2.0)**2 /(TC(1)*TC(2)*TR(1) 1*TR(2)) RETURN 130 IJ=0 DO 140 J=1,M DO 140 I=1,N IJ=IJ+1 E=TR(I)*TC(J)/GT IF(E-1.0) 135, 140, 140 135 IERR=1 140 CS=CS+(A(IJ)-E)*(A(IJ)-E)/E RETURN END SUBROUTINE CINT(A,N,LA,LB) DIMENSION A(1) ILA=N*(LA-1) ILB=N*(LB-1) DO 3 I=1,N ILA=ILA+1 ILB=ILB+1 SAVE=A(ILA) A(ILA)=A(ILB) 3 A(ILB)=SAVE RETURN END SUBROUTINE CNP(Y,X,N) DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN 2 Y(2)=X IF(N-1)1,1,3 3 F=X+X DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END SUBROUTINE CNPS(Y,X,C,N) DIMENSION C(1) IF(N)1,1,2 1 RETURN 2 IF(N-2)3,4,4 3 Y=C(1) RETURN 4 ARG=X+X H1=0. H0=0. DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5*(C(1)-H2+H0) RETURN END SUBROUTINE CONVT (N,M,MODE,S,D,MS) DIMENSION S(1),D(1) DOUBLE PRECISION D IF(MS-1) 2, 4, 6 2 NM=N*M GO TO 8 4 NM=((N+1)*N)/2 GO TO 8 6 NM=N 8 IF(MODE-1) 10, 10, 20 10 DO 15 L=1,NM 15 D(L)=S(L) GO TO 30 20 DO 25 L=1,NM 25 S(L)=D(L) 30 RETURN END SUBROUTINE CORRE (N,M,IO,X,XBAR,STD,RX,R,B,D,T) DIMENSION X(1),XBAR(1),STD(1),RX(1),R(1),B(1),D(1),T(1) DO 100 J=1,M B(J)=0.0 100 T(J)=0.0 K=(M*M+M)/2 DO 102 I=1,K 102 R(I)=0.0 FN=N L=0 IF(IO) 105, 127, 105 105 DO 108 J=1,M DO 107 I=1,N L=L+1 107 T(J)=T(J)+X(L) XBAR(J)=T(J) 108 T(J)=T(J)/FN DO 115 I=1,N JK=0 L=I-N DO 110 J=1,M L=L+N D(J)=X(L)-T(J) 110 B(J)=B(J)+D(J) DO 115 J=1,M DO 115 K=1,J JK=JK+1 115 R(JK)=R(JK)+D(J)*D(K) GO TO 205 127 IF(N-M) 130, 130, 135 130 KK=N GO TO 137 135 KK=M 137 DO 140 I=1,KK CALL DATA (M,D) DO 140 J=1,M T(J)=T(J)+D(J) L=L+1 140 RX(L)=D(J) FKK=KK DO 150 J=1,M XBAR(J)=T(J) 150 T(J)=T(J)/FKK L=0 DO 180 I=1,KK JK=0 DO 170 J=1,M L=L+1 170 D(J)=RX(L)-T(J) DO 180 J=1,M B(J)=B(J)+D(J) DO 180 K=1,J JK=JK+1 180 R(JK)=R(JK)+D(J)*D(K) IF(N-KK) 205, 205, 185 185 KK=N-KK DO 200 I=1,KK JK=0 CALL DATA (M,D) DO 190 J=1,M XBAR(J)=XBAR(J)+D(J) D(J)=D(J)-T(J) 190 B(J)=B(J)+D(J) DO 200 J=1,M DO 200 K=1,J JK=JK+1 200 R(JK)=R(JK)+D(J)*D(K) 205 JK=0 DO 210 J=1,M XBAR(J)=XBAR(J)/FN DO 210 K=1,J JK=JK+1 210 R(JK)=R(JK)-B(J)*B(K)/FN JK=0 DO 220 J=1,M JK=JK+J 220 STD(J)= SQRT( ABS(R(JK))) DO 230 J=1,M DO 230 K=J,M JK=J+(K*K-K)/2 L=M*(J-1)+K RX(L)=R(JK) L=M*(K-1)+J RX(L)=R(JK) IF(STD(J)*STD(K)) 225, 222, 225 222 R(JK)=0.0 GO TO 230 225 R(JK)=R(JK)/(STD(J)*STD(K)) 230 CONTINUE FN=SQRT(FN-1.0) DO 240 J=1,M 240 STD(J)=STD(J)/FN L=-M DO 250 I=1,M L=L+M+1 250 B(I)=RX(L) RETURN END SUBROUTINE CROSS (A,B,N,L,R,S) DIMENSION A(1),B(1),R(1),S(1) FN=N AVERA=0.0 AVERB=0.0 IF(N-L)50,50,100 50 R(1)=0.0 S(1)=0.0 RETURN 100 DO 110 I=1,N AVERA=AVERA+A(I) 110 AVERB=AVERB+B(I) AVERA=AVERA/FN AVERB=AVERB/FN DO 130 J=1,L NJ=N-J+1 SUMR=0.0 SUMS=0.0 DO 120 I=1,NJ IJ=I+J-1 SUMR=SUMR+(A(I)-AVERA)*(B(IJ)-AVERB) 120 SUMS=SUMS+(A(IJ)-AVERA)*(B(I)-AVERB) FNJ=NJ R(J)=SUMR/FNJ 130 S(J)=SUMS/FNJ RETURN END SUBROUTINE CS(C,S,X) Z=ABS(X) IF(Z-4.)1,1,2 1 C=SQRT(Z) S=Z*C Z=(4.-Z)*(4.+Z) C=C*((((((5.100785E-11*Z+5.244297E-9)*Z+5.451182E-7)*Z 1+3.273308E-5)*Z+1.020418E-3)*Z+1.102544E-2)*Z+1.840965E-1) S=S*(((((6.677681E-10*Z+5.883158E-8)*Z+5.051141E-6)*Z 1+2.441816E-4)*Z+6.121320E-3)*Z+8.026490E-2) RETURN 2 D=COS(Z) S=SIN(Z) Z=4./Z A=(((((((8.768258E-4*Z-4.169289E-3)*Z+7.970943E-3)*Z-6.792801E-3) 1*Z-3.095341E-4)*Z+5.972151E-3)*Z-1.606428E-5)*Z-2.493322E-2)*Z 2-4.444091E-9 B=((((((-6.633926E-4*Z+3.401409E-3)*Z-7.271690E-3)*Z+7.428246E-3) 1*Z-4.027145E-4)*Z-9.314910E-3)*Z-1.207998E-6)*Z+1.994711E-1 Z=SQRT(Z) C=0.5+Z*(D*A+S*B) S=0.5+Z*(S*A-D*B) RETURN END SUBROUTINE CSP(Y,X,N) DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN 2 Y(2)=X+X-1. IF(N-1)1,1,3 3 F=Y(2)+Y(2) DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END SUBROUTINE CSPS(Y,X,C,N) DIMENSION C(1) IF(N)1,1,2 1 RETURN 2 IF(N-2)3,4,4 3 Y=C(1) RETURN 4 ARG=X+X-1. ARG=ARG+ARG H1=0. H0=0. DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5*(C(1)-H2+H0) RETURN END SUBROUTINE CSRT(A,B,R,N,M,MS) DIMENSION A(1),B(1),R(1) IK=1 DO 10 J=1,M R(IK)=B(J) R(IK+1)=J 10 IK=IK+N L=M+1 20 ISORT=0 L=L-1 IP=1 IQ=N+1 DO 50 J=2,L IF(R(IQ)-R(IP)) 30,40,40 30 ISORT=1 RSAVE=R(IQ) R(IQ)=R(IP) R(IP)=RSAVE SAVER=R(IQ+1) R(IQ+1)=R(IP+1) R(IP+1)=SAVER 40 IP=IP+N IQ=IQ+N 50 CONTINUE IF(ISORT) 20,60,20 60 IQ=-N DO 70 J=1,M IQ=IQ+N I2=IQ+2 IN=R(I2) IR=IQ+1 CALL CCPY(A,IN,R(IR),N,M,MS) 70 CONTINUE RETURN END SUBROUTINE CSUM(A,R,N,M,MS) DIMENSION A(1),R(1) DO 3 J=1,M R(J)=0.0 DO 3 I=1,N CALL LOC(I,J,IJ,N,M,MS) IF(IJ) 2,3,2 2 R(J)=R(J)+A(IJ) 3 CONTINUE RETURN END SUBROUTINE CTAB(A,B,R,S,N,M,MS,L) DIMENSION A(1),B(1),R(1),S(1) CALL LOC(N,L,IT,N,L,0) DO 10 IR=1,IT 10 R(IR)=0.0 DO 20 IS=1,L 20 S(IS)=0.0 S(L+1)=0.0 DO 60 I=1,M JR=B(I) IF (JR-1) 50,40,30 30 IF (JR-L) 40,40,50 40 CALL CADD (A,I,R,JR,N,M,MS,L) S(JR)=S(JR)+1.0 GO TO 60 50 S(L+1)=S(L+1)+1.0 60 CONTINUE RETURN END SUBROUTINE CTIE(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) MM=M IR=0 MSX=MSA DO 6 JJ=1,2 DO 5 J=1,MM DO 5 I=1,N IR=IR+1 R(IR)=0.0 CALL LOC(I,J,IJ,N,MM,MSX) IF(IJ) 2,5,2 2 GO TO(3,4),JJ 3 R(IR)=A(IJ) GO TO 5 4 R(IR)=B(IJ) 5 CONTINUE MSX=MSB MM=L 6 CONTINUE RETURN END SUBROUTINE DACFI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,Z,P1,P2,P3,Q1,Q2,Q3,AUX,H IER=2 IF(NDIM)20,20,1 1 Y=VAL(1) DELT2=0. IF(NDIM-1)20,20,2 2 P2=1.D0 P3=Y Q2=0.D0 Q3=1.D0 DO 16 I=2,NDIM II=0 P1=P2 P2=P3 Q1=Q2 Q2=Q3 Z=Y DELT1=DELT2 JEND=I-1 3 AUX=VAL(I) DO 10 J=1,JEND H=VAL(I)-VAL(J) IF(DABS(H)-1.D-13*DABS(VAL(I)))4,4,9 4 IF(ARG(I)-ARG(J))5,17,5 5 IF(J-JEND)8,6,6 6 II=II+1 III=I+II IF(III-NDIM)7,7,19 7 VAL(I)=VAL(III) VAL(III)=AUX AUX=ARG(I) ARG(I)=ARG(III) ARG(III)=AUX GOTO 3 8 VAL(I)=1.D33 GOTO 10 9 VAL(I)=(ARG(I)-ARG(J))/H 10 CONTINUE P3=VAL(I)*P2+(X-ARG(I-1))*P1 Q3=VAL(I)*Q2+(X-ARG(I-1))*Q1 IF(Q3)11,12,11 11 Y=P3/Q3 GOTO 13 12 Y=1.D33 13 DELT2=DABS(Z-Y) IF(DELT2-EPS)19,19,14 14 IF(I-10)16,15,15 15 IF(DELT2-DELT1)16,18,18 16 CONTINUE RETURN 17 IER=3 RETURN 18 Y=Z IER=1 RETURN 19 IER=0 20 RETURN END SUBROUTINE DAHI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,H,H1,H2 IER=2 H2=X-ARG(1) IF(NDIM-1)2,1,3 1 Y=VAL(1)+VAL(2)*H2 2 RETURN 3 I=1 DO 5 J=2,NDIM H1=H2 H2=X-ARG(J) Y=VAL(I) VAL(I)=Y+VAL(I+1)*H1 H=H1-H2 IF(H)4,13,4 4 VAL(I+1)=Y+(VAL(I+2)-Y)*H1/H 5 I=I+2 VAL(I)=VAL(I)+VAL(I+1)*H2 DELT2=0. IEND=I-1 DO 9 I=1,IEND DELT1=DELT2 Y=VAL(1) M=(I+3)/2 H1=ARG(M) DO 6 J=1,I K=I+1-J L=(K+1)/2 H=ARG(L)-H1 IF(H)6,14,6 6 VAL(K)=(VAL(K)*(X-H1)-VAL(K+1)*(X-ARG(L)))/H DELT2=DABS(Y-VAL(1)) IF(DELT2-EPS)11,11,7 7 IF(I-8)9,8,8 8 IF(DELT2-DELT1)9,12,12 9 CONTINUE 10 Y=VAL(1) RETURN 11 IER=0 GOTO 10 12 IER=1 RETURN 13 Y=VAL(1) 14 IER=3 RETURN END SUBROUTINE DALI(X,ARG,VAL,Y,NDIM,EPS,IER) DIMENSION ARG(1),VAL(1) DOUBLE PRECISION ARG,VAL,X,Y,H IER=2 DELT2=0. IF(NDIM-1)9,7,1 1 DO 6 J=2,NDIM DELT1=DELT2 IEND=J-1 DO 2 I=1,IEND H=ARG(I)-ARG(J) IF(H)2,13,2 2 VAL(J)=(VAL(I)*(X-ARG(J))-VAL(J)*(X-ARG(I)))/H DELT2=DABS(VAL(J)-VAL(IEND)) IF(J-2)6,6,3 3 IF(DELT2-EPS)10,10,4 4 IF(J-8)6,5,5 5 IF(DELT2-DELT1)6,11,11 6 CONTINUE 7 J=NDIM 8 Y=VAL(J) 9 RETURN 10 IER=0 GOTO 8 11 IER=1 12 J=IEND GOTO 8 13 IER=3 GOTO 12 END SUBROUTINE DLAP(Y,X,N) DIMENSION Y(1) DOUBLE PRECISION Y,X,T Y(1)=1.D0 IF(N)1,1,2 1 RETURN 2 Y(2)=1.D0-X IF(N-1)1,1,3 3 T=1.D0+X DO 4 I=2,N 4 Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/DFLOAT(I) RETURN END SUBROUTINE DAPCH(DATI,N,IP,XD,X0,WORK,IER) DIMENSION DATI(1),WORK(1) DOUBLE PRECISION DATI,WORK,XD,X0,XA,XE,XM,DF,T,SUM IF(N-1)19,20,1 1 IF(IP)19,19,2 2 IF(IP-N)3,3,19 3 XA=DATI(1) X0=XA XE=0.D0 DO 7 I=1,N XM=DATI(I) IF(XA-XM)5,5,4 4 XA=XM 5 IF(X0-XM)6,7,7 6 X0=XM 7 CONTINUE XD=X0-XA M=(IP*(IP+1))/2 IEND=M+IP+1 MT2=IP+IP MT2M=MT2-1 DO 8 I=1,IP J=MT2-I WORK(J)=0.D0 WORK(I)=0.D0 K=M+I 8 WORK(K)=0.D0 IF(XD)20,20,9 9 X0=-(X0+XA)/XD XD=2.D0/XD SUM=0.D0 DO 15 I=1,N T=DATI(I)*XD+X0 J=I+N DF=DATI(J) XA=1.D0 XM=T IF(DATI(2*N+1))11,11,10 10 J=J+N XA=DATI(J) XM=T*XA 11 T=T+T SUM=SUM+DF*DF*XA DF=DF+DF J=1 12 K=M+J WORK(K)=WORK(K)+DF*XA 13 WORK(J)=WORK(J)+XA IF(J-MT2M)14,15,15 14 J=J+1 XE=T*XM-XA XA=XM XM=XE IF(J-IP)12,12,13 15 CONTINUE WORK(IEND)=SUM+SUM LL=M KK=MT2M JJ=1 K=KK DO 18 J=1,M WORK(LL)=WORK(K)+WORK(JJ) LL=LL-1 IF(K-JJ)16,16,17 16 KK=KK-2 K=KK JJ=1 GOTO 18 17 JJ=JJ+1 K=K-1 18 CONTINUE IER=0 RETURN 19 IER=-1 RETURN 20 IER=1 RETURN END SUBROUTINE DAPFS(WORK,IP,IRES,IOP,EPS,ETA,IER) DIMENSION WORK(1) DOUBLE PRECISION WORK,SUM,PIV IRES=0 IF(IP)1,1,2 1 IER=-1 RETURN 2 IPIV=0 IPP1=IP+1 IER=1 ITE=IP*IPP1/2 IEND=ITE+IPP1 TOL=ABS(EPS*SNGL(WORK(1))) TEST=ABS(ETA*SNGL(WORK(IEND))) DO 11 I=1,IP IPIV=IPIV+I JA=IPIV-IRES JE=IPIV-1 JK=IPIV DO 9 K=I,IPP1 SUM=0.D0 IF(IRES)5,5,3 3 JK=JK-IRES DO 4 J=JA,JE SUM=SUM+WORK(J)*WORK(JK) 4 JK=JK+1 5 IF(JK-IPIV)6,6,8 6 SUM=WORK(IPIV)-SUM IF(SNGL(SUM)-TOL)12,12,7 7 SUM=DSQRT(SUM) WORK(IPIV)=SUM PIV=1.D0/SUM GOTO 9 8 SUM=(WORK(JK)-SUM)*PIV WORK(JK)=SUM 9 JK=JK+K WORK(IEND)=WORK(IEND)-SUM*SUM IRES=IRES+1 IADR=IPIV IF(IOP)10,11,11 10 IF(SNGL(WORK(IEND))-TEST)13,13,11 11 CONTINUE IF(IOP)12,22,12 12 IF(IOP)14,23,14 13 IER=0 14 IPIV=IRES 15 IF(IPIV)23,23,16 16 SUM=0.D0 JA=ITE+IPIV JJ=IADR JK=IADR K=IPIV DO 19 I=1,IPIV WORK(JK)=(WORK(JA)-SUM)/WORK(JJ) IF(K-1)20,20,17 17 JE=JJ-1 SUM=0.D0 DO 18 J=K,IPIV SUM=SUM+WORK(JK)*WORK(JE) JK=JK+1 18 JE=JE+J JK=JE-IPIV JA=JA-1 JJ=JJ-K 19 K=K-1 20 IF(IOP/2)21,23,21 21 IADR=IADR-IPIV IPIV=IPIV-1 GOTO 15 22 IER=0 23 RETURN END SUBROUTINE DAPLL(FFCT,N,IP,P,WORK,DATI,IER) DIMENSION P(1),WORK(1),DATI(1),IER(1) DOUBLE PRECISION P,WORK,DATI,WGT,AUX IF(N)10,10,1 1 IF(IP)10,10,2 2 IF(N-IP)10,3,3 3 IPP1=IP+1 M=IPP1*(IP+2)/2 IER(1)=0 DO 4 I=1,M 4 WORK(I)=0.D0 DO 8 I=1,N CALL FFCT(I,N,IP,P,DATI,WGT,IER) IF(IER(1))9,5,9 5 J=0 DO 7 K=1,IPP1 AUX=P(K)*WGT DO 6 L=1,K J=J+1 6 WORK(J)=WORK(J)+P(L)*AUX 7 CONTINUE 8 CONTINUE 9 RETURN 10 IER(1)=-1 RETURN END SUBROUTINE DAPMM(FCT,N,M,TOP,IHE,PIV,T,ITER,IER) DIMENSION TOP(1),IHE(1),PIV(1),T(1) DOUBLE PRECISION DSUM,TOP,PIV,T,SAVE,HELP,REPI,TOL IER=-1 IF (N-1) 81,81,1 1 IF(M) 81,81,2 2 IER=0 DO 3 I=1,N K=I+N J=K+N TOP(J)=TOP(K) 3 TOP(K)=-TOP(I) L=M+2 LL=L*L DO 4 I=1,LL 4 T(I)=0.D0 K=1 J=L+1 DO 5 I=1,L T(K)=1.D0 5 K=K+J DO 6 I=1,L K=I+L J=K+L IHE(I)=0 IHE(K)=I 6 IHE(J)=1-I NAN=N+N K=L+L+L J=K+NAN DO 7 I=1,NAN K=K+1 IHE(K)=I J=J+1 7 IHE(J)=I ITER=-1 8 ITER=ITER+1 IF(N+M-ITER) 9,9,10 9 IER=1 GO TO 69 10 ISE=0 IPIV=0 K=L+L+L SAVE=0.D0 DO 14 I=1,NAN IDO=K+I HELP=TOP(I) IF(HELP-SAVE) 12,12,11 11 SAVE=HELP IPIV=I 12 IF(IHE(IDO)) 14,13,14 13 ISE=I 14 CONTINUE IF(IPIV) 69,69,15 15 ILAB=1 IND=0 J=ISE IF(J) 21,21,34 16 K=(K-1)*L DO 17 I=1,L J=L+I K=K+1 17 PIV(J)=T(K) 18 IF(ISE) 22,22,19 19 ISE=-ISE J=L+1 IDO=L+L DO 20 I=J,IDO K=I+L 20 PIV(K)=PIV(I) 21 J=IPIV GO TO 34 22 SAVE=1.D38 IDO=0 K=L+1 LL=L+L IND=0 DO 29 I=K,LL J=I+L HELP=PIV(I) IF(HELP) 29,29,23 23 HELP=-HELP IF(ISE) 26,24,26 24 IF(IHE(J)) 27,25,27 25 IDO=I GO TO 29 26 HELP=-PIV(J)/HELP 27 IF(HELP-SAVE) 28,29,29 28 SAVE=HELP IND=I 29 CONTINUE IF(IND) 30,30,32 30 IF(IDO) 68,68,31 31 IND=IDO 32 REPI=1.D0/PIV(IND) IND=IND-L ILAB=0 SAVE=-TOP(IPIV)*REPI TOP(IPIV)=SAVE J=NAN 33 IF(J-IPIV) 34,53,34 34 K=0 DO 36 I=1,L IF(IHE(I)-J) 36,35,36 35 K=I IF(ILAB) 50,50,16 36 CONTINUE I=L+L+L+NAN+J I=IHE(I)-N IF(I) 37,37,38 37 I=I+N K=1 38 I=I+NAN CALL FCT(PIV,TOP(I),M-1) DSUM=0.D0 IDO=M DO 41 I=1,M HELP=PIV(IDO) IF(K) 39,39,40 39 HELP=-HELP 40 DSUM=DSUM+HELP PIV(IDO+1)=HELP 41 IDO=IDO-1 PIV(L)=-DSUM PIV(1)=1.D0 IDO=IND IF(ILAB) 44,44,42 42 K=1 43 IDO=K 44 DSUM=0.D0 HELP=0.D0 DO 46 I=1,L DSUM=DSUM+PIV(I)*T(IDO) TOL=DABS(DSUM) IF(TOL-HELP) 46,46,45 45 HELP=TOL 46 IDO=IDO+L TOL=1.D-14*HELP IF(DABS(DSUM)-TOL) 47,47,48 47 DSUM=0.D0 48 IF(ILAB) 51,51,49 49 I=K+L PIV(I)=DSUM K=K+1 IF(K-L) 43,43,18 50 I=(K-1)*L+IND DSUM=T(I) 51 DSUM=DSUM*SAVE TOL=1.D-14*DABS(DSUM) TOP(J)=TOP(J)+DSUM IF(DABS(TOP(J))-TOL) 52,52,53 52 TOP(J)=0.D0 53 J=J-1 IF(J) 54,54,33 54 I=IND+L PIV(I)=-1.D0 DO 55 I=1,L J=I+L 55 PIV(I)=-PIV(J)*REPI J=0 DO 57 I=1,L IDO=J+IND SAVE=T(IDO) T(IDO)=0.D0 DO 56 K=1,L ISE=K+J 56 T(ISE)=T(ISE)+SAVE*PIV(K) 57 J=J+L J=0 K=0 ISE=0 IDO=0 DO 61 I=1,L LL=I+L ILAB=IHE(LL) IF(IHE(I)-IPIV) 59,58,59 58 ISE=I J=ILAB 59 IF(ILAB-IND) 61,60,61 60 IDO=I K=IHE(I) 61 CONTINUE IF(K) 62,62,63 62 IHE(IDO)=IPIV IF(ISE) 67,67,65 63 IF(IND-J) 64,66,64 64 LL=L+L+L+NAN K=K+LL I=IPIV+LL ILAB=IHE(K) IHE(K)=IHE(I) IHE(I)=ILAB IF(ISE) 67,67,65 65 IDO=IDO+L I=ISE+L IHE(IDO)=J IHE(I)=IND 66 IHE(ISE)=0 67 LL=L+L J=LL+IND I=LL+L+IPIV ILAB=IHE(I) IHE(I)=IHE(J) IHE(J)=ILAB GO TO 8 68 IER=-1 69 SAVE=0.D0 HELP=0.D0 K=L+L+L DO 73 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 71,70,73 70 SAVE=-TOP(I) 71 IF(M+J+1) 73,72,73 72 HELP=TOP(I) 73 CONTINUE T(1)=SAVE IDO=NAN+1 J=NAN+N DO 74 I=IDO,J 74 TOP(I)=SAVE DO 75 I=1,M 75 PIV(I)=HELP DO 79 I=1,NAN IDO=K+I J=IHE(IDO) IF(J) 76,79,77 76 J=-J PIV(J)=HELP-TOP(I) GO TO 79 77 IF(J-N) 78,78,79 78 J=J+NAN TOP(J)=SAVE+TOP(I) 79 CONTINUE DO 80 I=1,N IDO=NAN+I 80 TOP(I)=TOP(IDO) 81 RETURN END SUBROUTINE DLAPS(Y,X,C,N) DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,T IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1.D0 H1=1.D0-X T=1.D0+X DO 4 I=2,N H2=H1-H0+H1-(T*H1-H0)/DFLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END SUBROUTINE DARAT(DATI,N,WORK,P,IP,IQ,IER) EXTERNAL DFRAT DIMENSION IERV(3) DIMENSION DATI(1),WORK(1),P(1) DOUBLE PRECISION DATI,WORK,P,T,OSUM,DIAG,RELAX,SUM,SSOE,SAVE LIMIT=20 ETA=1.E-29 EPS=1.E-14 IF(N)4,4,1 1 IF(IP)4,4,2 2 IF(IQ)4,4,3 3 IPQ=IP+IQ IF(N-IPQ)4,5,5 4 IER=-1 RETURN 5 KOUNT=0 IERV(2)=IP IERV(3)=IQ NDP=N+N+1 NNE=NDP+NDP IX=IPQ-1 IQP1=IQ+1 IRHS=NNE+IPQ*IX/2 IEND=IRHS+IX IF(IER)8,6,8 6 DO 7 I=2,IPQ 7 P(I)=0.D0 P(1)=1.D0 8 DO 9 J=1,N T=DATI(J) I=J+N CALL DCNPS(WORK(I),T,P(IQP1),IP) K=I+N 9 CALL DCNPS(WORK(K),T,P,IQ) 10 CALL DAPLL(DFRAT,N,IX,WORK,WORK(IEND+1),DATI,IERV) IF(IERV(1))4,11,4 11 INCR=0 RELAX=2.D0 12 J=IEND DO 13 I=NNE,IEND J=J+1 13 WORK(I)=WORK(J) IF(KOUNT)14,14,15 14 OSUM=WORK(IEND) DIAG=OSUM*EPS K=IQ IF(WORK(NNE))17,17,19 15 IF(INCR)19,19,16 16 K=IPQ 17 J=NNE-1 DO 18 I=1,K WORK(J)=WORK(J)+DIAG 18 J=J+I 19 CALL DAPFS(WORK(NNE),IX,IRES,1,EPS,ETA,IER) IF(IRES)4,4,20 20 IF(IRES-IX)21,24,24 21 IF(INCR)22,22,23 22 DIAG=DIAG*0.125D0 23 DIAG=DIAG+DIAG INCR=INCR+1 RELAX=8.D0 IF(INCR-LIMIT)12,45,45 24 L=NDP J=NNE+IRES*(IRES-1)/2-1 K=J+IQ WORK(J)=0.D0 IRQ=IQ IRP=IRES-IQ+1 IF(IRP)25,26,26 25 IRQ=IRES+1 26 DO 29 I=1,N T=DATI(I) WORK(I)=0.D0 CALL DCNPS(WORK(I),T,WORK(K),IRP) M=L+N CALL DCNPS(WORK(M),T,WORK(J),IRQ) IF(WORK(M)*WORK(L))27,29,29 27 SUM=WORK(L)/WORK(M) IF(RELAX+SUM)29,29,28 28 RELAX=-SUM 29 L=L+1 SSOE=OSUM ITER=LIMIT 30 SUM=0.D0 RELAX=RELAX*0.5D0 DO 32 I=1,N M=I+N K=M+N L=K+N SAVE=DATI(M)-(WORK(M)+RELAX*WORK(I))/(WORK(K)+RELAX*WORK(L)) SAVE=SAVE*SAVE IF(DATI(NDP))32,32,31 31 SAVE=SAVE*DATI(K) 32 SUM=SUM+SAVE IF(ITER)45,33,33 33 ITER=ITER-1 IF(SUM-OSUM)34,37,35 34 OSUM=SUM GOTO 30 35 IF(OSUM-SSOE)36,30,30 36 RELAX=RELAX+RELAX 37 T=0. SAVE=0.D0 K=IRES+1 DO 38 I=2,K J=J+1 T=T+DABS(P(I)) P(I)=P(I)+RELAX*WORK(J) 38 SAVE=SAVE+DABS(P(I)) DO 39 I=1,N J=I+N K=J+N L=K+N WORK(J)=WORK(J)+RELAX*WORK(I) 39 WORK(K)=WORK(K)+RELAX*WORK(L) IF(INCR)40,40,42 40 IF(SSOE-OSUM-RELAX*OSUM*DBLE(EPS))46,46,41 41 IF(DABS(T-SAVE)-RELAX*SAVE*DBLE(EPS))46,46,42 42 IF(OSUM-SAVE*DBLE(ETA))46,46,43 43 KOUNT=KOUNT+1 IF(KOUNT-LIMIT)10,44,44 44 IER=2 RETURN 45 IER=1 RETURN 46 IER=0 RETURN END SUBROUTINE DQA12(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.36191360360615602D2 Y=.33287369929782177D-15*FCT(X) X=.27661108779846090D2 Y=Y+.13169240486156340D-11*FCT(X) X=.21396755936166109D2 Y=Y+.60925085399751278D-9*FCT(X) X=.16432195087675313D2 Y=Y+.8037942349882859D-7*FCT(X) X=.12390447963809471D2 Y=Y+.43164914098046673D-5*FCT(X) X=.9075434230961203D1 Y=Y+.11377383272808760D-3*FCT(X) X=.63699753880306349D1 Y=Y+.16473849653768349D-2*FCT(X) X=.41984156448784132D1 Y=Y+.14096711620145342D-1*FCT(X) X=.25098480972321280D1 Y=Y+.7489094100646149D-1*FCT(X) X=.12695899401039615D1 Y=Y+.25547924356911832D0*FCT(X) X=.45450668156378028D0 Y=Y+.57235907069288604D0*FCT(X) X=.50361889117293951D-1 Y=Y+.8538623277373985D0*FCT(X) RETURN END SUBROUTINE DQA16(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.50777223877537080D2 Y=.14621352854768325D-21*FCT(X) X=.41081666525491202D2 Y=Y+.18463473073036584D-17*FCT(X) X=.33781970488226166D2 Y=Y+.23946880341856973D-14*FCT(X) X=.27831438211328676D2 Y=Y+.8430020422652895D-12*FCT(X) X=.22821300693525208D2 Y=Y+.11866582926793277D-9*FCT(X) X=.18537743178606694D2 Y=Y+.8197664329541793D-8*FCT(X) X=.14851431341801250D2 Y=Y+.31483355850911881D-6*FCT(X) X=.11677033673975957D2 Y=Y+.7301170259124752D-5*FCT(X) X=.8955001337723390D1 Y=Y+.10833168123639965D-3*FCT(X) X=.66422151797414440D1 Y=Y+.10725367310559441D-2*FCT(X) X=.47067267076675872D1 Y=Y+.7309780653308856D-2*FCT(X) X=.31246010507021443D1 Y=Y+.35106857663146861D-1*FCT(X) X=.18779315076960743D1 Y=Y+.12091626191182523D0*FCT(X) X=.9535531553908655D0 Y=Y+.30253946815328497D0*FCT(X) X=.34220015601094768D0 Y=Y+.55491628460505980D0*FCT(X) X=.37962914575313455D-1 Y=Y+.7504767051856048D0*FCT(X) RETURN END SUBROUTINE DQA24(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.8055628081995041D2 Y=.15871102921547994D-34*FCT(X) X=.69068601975304369D2 Y=Y+.11969225386627757D-29*FCT(X) X=.60206666963057223D2 Y=Y+.7370072160301340D-26*FCT(X) X=.52795432527283630D2 Y=Y+.11129154937804570D-22*FCT(X) X=.46376979557540133D2 Y=Y+.63767746470102769D-20*FCT(X) X=.40711598185543107D2 Y=Y+.17460319202373353D-17*FCT(X) X=.35653703516328212D2 Y=Y+.26303192453168170D-15*FCT(X) X=.31106464709046565D2 Y=Y+.23951797309583587D-13*FCT(X) X=.27001406056472356D2 Y=Y+.14093865163091778D-11*FCT(X) X=.23287932824879917D2 Y=Y+.56305930756763382D-10*FCT(X) X=.19927425875242462D2 Y=Y+.15860934990330765D-8*FCT(X) X=.16889671928527108D2 Y=Y+.32450282717915397D-7*FCT(X) X=.14150586187285759D2 Y=Y+.49373179873395010D-6*FCT(X) X=.11690695926056073D2 Y=Y+.56945173834696962D-5*FCT(X) X=.9494095330026488D1 Y=Y+.50571980554969778D-4*FCT(X) X=.7547704680023454D1 Y=Y+.35030086360234566D-3*FCT(X) X=.58407332713236080D1 Y=Y+.19127846396388306D-2*FCT(X) X=.43642830769353062D1 Y=Y+.8306009823955105D-2*FCT(X) X=.31110524551477130D1 Y=Y+.28889923149962199D-1*FCT(X) X=.20751129098523806D1 Y=Y+.8095935396920770D-1*FCT(X) X=.12517406323627464D1 Y=Y+.18364459415857036D0*FCT(X) X=.63729027873266879D0 Y=Y+.33840894389128221D0*FCT(X) X=.22910231649262433D0 Y=Y+.50792308532951820D0*FCT(X) X=.25437996585689359D-1 Y=Y+.62200206075592616D0*FCT(X) RETURN END SUBROUTINE DQA32(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.11079926894707576D3 Y=0 X=.9791671642606276D2 X=.8785611994313352D2 X=.7933908652882320D2 Y=Y+.31147812492595276D-34*FCT(X) X=.71868499359551422D2 Y=Y+.50993217982259985D-31*FCT(X) X=.65184426376135782D2 Y=Y+.38582071909299337D-28*FCT(X) X=.59129027934391951D2 Y=Y+.15723595577851821D-25*FCT(X) X=.53597231826148512D2 Y=Y+.38234137666012857D-23*FCT(X) X=.48514583867416048D2 Y=Y+.59657255685597023D-21*FCT(X) X=.43825886369903902D2 Y=Y+.63045091330075628D-19*FCT(X) X=.39488797123368127D2 Y=Y+.47037694213516382D-17*FCT(X) X=.35469961396173283D2 Y=Y+.25601867826448761D-15*FCT(X) X=.31742543790616606D2 Y=Y+.10437247453181695D-13*FCT(X) X=.28284583194970531D2 Y=Y+.32566814614194407D-12*FCT(X) X=.25077856544198053D2 Y=Y+.7918355533895448D-11*FCT(X) X=.22107070382206007D2 Y=Y+.15230434500290903D-9*FCT(X) X=.19359271087268714D2 Y=Y+.23472334846430987D-8*FCT(X) X=.16823405362953694D2 Y=Y+.29302506329522187D-7*FCT(X) X=.14489986690780274D2 Y=Y+.29910658734544941D-6*FCT(X) X=.12350838217714770D2 Y=Y+.25166805020623692D-5*FCT(X) X=.10398891905552624D2 Y=Y+.17576998461700718D-4*FCT(X) X=.8628029857405929D1 Y=Y+.10251858271572549D-3*FCT(X) X=.70329577982838936D1 Y=Y+.50196739702612497D-3*FCT(X) X=.56091034574961513D1 Y=Y+.20726581990151553D-2*FCT(X) X=.43525345293301410D1 Y=Y+.7245173957068918D-2*FCT(X) X=.32598922564569419D1 Y=Y+.21512081019758274D-1*FCT(X) X=.23283376682103970D1 Y=Y+.54406257907377837D-1*FCT(X) X=.15555082314789380D1 Y=Y+.11747996392819887D0*FCT(X) X=.9394832145007343D0 Y=Y+.21699669861237368D0*FCT(X) X=.47875647727748885D0 Y=Y+.34337168469816740D0*FCT(X) X=.17221572414539558D0 Y=Y+.46598957212535609D0*FCT(X) X=.19127510968446856D-1 Y=Y+.54275484988260796D0*FCT(X) RETURN END SUBROUTINE DBAR(X,H,IH,FCT,Z) DIMENSION AUX(10) IF(H)1,17,1 1 C=ABS(H) B=H D=X D=FCT(D) IF(IH)2,9,2 2 HH=.5 IF(C-HH)3,4,4 3 HH=B 4 HH=SIGN(HH,B) Z=ABS((FCT(X+HH)-D)/HH) A=ABS(D) HH=1. IF(A-1.)6,6,5 5 HH=HH*A 6 IF(Z-1.)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=B 10 HH=SIGN(HH,B) Z=(FCT(X+HH)-D)/HH J=10 JJ=J-1 AUX(J)=Z DH=HH/FLOAT(J) DZ=1.E33 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-D)/HH D2=1.E33 B=0. A=1./C DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/B AUX(I+1)=AUX(I)+HH D2=ABS(HH) IF(D2-D1)12,13,13 12 CONTINUE I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 17 RETURN END SUBROUTINE DCAR(X,H,IH,FCT,Z) DIMENSION AUX(5) IF(H)1,17,1 1 C=ABS(H) IF(IH)2,9,2 2 HH=.5 IF(C-HH)3,4,4 3 HH=C 4 A=FCT(X+HH) B=FCT(X-HH) Z=ABS((A-B)/(HH+HH)) A=.5*ABS(A+B) HH=.5 IF(A-1.)6,6,5 5 HH=HH*A 6 IF(Z-1.)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=C 10 Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH) J=5 JJ=J-1 AUX(J)=Z DH=HH/FLOAT(J) DZ=1.E33 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH) D2=1.E33 B=0. A=1./C DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/(B*(2.+B)) AUX(I+1)=AUX(I)+HH D2=ABS(HH) IF(D2-D1)12,13,13 12 CONTINUE I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 17 RETURN END SUBROUTINE DCEL1(RES,AK,IER) DOUBLE PRECISION RES,AK,GEO,ARI,AARI IER=0 ARI=2.D0 GEO=(0.5D0-AK)+0.5D0 GEO=GEO+GEO*AK RES=0.5D0 IF(GEO)1,2,4 1 IER=1 2 RES=1.D33 RETURN 3 GEO=GEO*AARI 4 GEO=DSQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO RES=RES+RES IF(GEO/AARI-0.999999995D0)3,5,5 5 RES=RES/ARI*6.2831853071795865D0 RETURN END SUBROUTINE DCEL2(RES,AK,A,B,IER) DOUBLE PRECISION RES,AK,A,B,GEO,ARI,AARI,B0,A1 IER=0 ARI=2.D0 GEO=(0.5D0-AK)+0.5D0 GEO=GEO+GEO*AK RES=A A1=A+B B0=B+B IF(GEO)1,2,6 1 IER=1 2 IF(B)3,8,4 3 RES=-1.D33 RETURN 4 RES=1.D33 RETURN 5 GEO=GEO*AARI 6 GEO=DSQRT(GEO) GEO=GEO+GEO AARI=ARI ARI=ARI+GEO B0=B0+RES*GEO RES=A1 B0=B0+B0 A1=B0/ARI+A1 IF(GEO/AARI-0.999999995D0)5,7,7 7 RES=A1/ARI RES=RES+0.57079632679489662D0*RES 8 RETURN END SUBROUTINE DCLA(A,C,N,MS) DIMENSION A(1) DO 3 I=1,N CALL LOC(I,I,ID,N,N,MS) 3 A(ID)=C RETURN END SUBROUTINE DCPY(A,R,N,MS) DIMENSION A(1),R(1) DO 3 J=1,N CALL LOC(J,J,IJ,N,N,MS) 3 R(J)=A(IJ) RETURN END SUBROUTINE DDBAR(X,H,IH,FCT,Z) DIMENSION AUX(10) DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,D,DH,HH IF(H)1,17,1 1 C=ABS(H) B=H D=X D=FCT(D) IF(IH)2,9,2 2 HH=.5D-2 IF(C-HH)3,4,4 3 HH=B 4 HH=DSIGN(HH,B) Z=DABS((FCT(X+HH)-D)/HH) A=DABS(D) HH=1.D-2 IF(A-1.D0)6,6,5 5 HH=HH*A 6 IF(Z-1.D0)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=B 10 HH=DSIGN(HH,B) Z=(FCT(X+HH)-D)/HH J=10 JJ=J-1 AUX(J)=Z DH=HH/DFLOAT(J) DZ=1.E33 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-D)/HH D2=1.E33 B=0.D0 A=1.D0/C DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/B AUX(I+1)=AUX(I)+HH D2=DABS(HH) IF(D2-D1)12,13,13 12 CONTINUE I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 17 RETURN END SUBROUTINE DDCAR(X,H,IH,FCT,Z) DIMENSION AUX(5) DOUBLE PRECISION X,FCT,Z,AUX,A,B,C,DH,HH IF(H)1,17,1 1 C=ABS(H) IF(IH)2,9,2 2 HH=.5D-2 IF(C-HH)3,4,4 3 HH=C 4 A=FCT(X+HH) B=FCT(X-HH) Z=DABS((A-B)/(HH+HH)) A=.5D0*DABS(A+B) HH=.5D-2 IF(A-1.D0)6,6,5 5 HH=HH*A 6 IF(Z-1.D0)8,8,7 7 HH=HH/Z 8 IF(HH-C)10,10,9 9 HH=C 10 Z=(FCT(X+HH)-FCT(X-HH))/(HH+HH) J=5 JJ=J-1 AUX(J)=Z DH=HH/DFLOAT(J) DZ=1.E33 11 J=J-1 C=J HH=C*DH AUX(J)=(FCT(X+HH)-FCT(X-HH))/(HH+HH) D2=1.E33 B=0.D0 A=1.D0/C DO 12 I=J,JJ D1=D2 B=B+A HH=(AUX(I)-AUX(I+1))/(B*(2.D0+B)) AUX(I+1)=AUX(I)+HH D2=DABS(HH) IF(D2-D1)12,13,13 12 CONTINUE I=JJ+1 GO TO 14 13 D2=D1 JJ=I 14 IF(D2-DZ)15,16,16 15 DZ=D2 Z=AUX(I) 16 IF(J-1)17,17,11 17 RETURN END SUBROUTINE DDGT3(X,Y,Z,NDIM,IER) DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,DY1,DY2,DY3,A,B IER=-1 IF(NDIM-3)8,1,1 1 A=X(1) B=Y(1) I=2 DY2=X(2)-A IF(DY2)2,9,2 2 DY2=(Y(2)-B)/DY2 DO 6 I=3,NDIM A=X(I)-A IF(A)3,9,3 3 A=(Y(I)-B)/A B=X(I)-X(I-1) IF(B)4,9,4 4 DY1=DY2 DY2=(Y(I)-Y(I-1))/B DY3=A A=X(I-1) B=Y(I-1) IF(I-3)5,5,6 5 Z(1)=DY1+DY3-DY2 6 Z(I-1)=DY1+DY2-DY3 IER=0 I=NDIM 7 Z(I)=DY2+DY3-DY1 8 RETURN 9 IER=I I=I-1 IF(I-2)8,8,7 END SUBROUTINE DDET3(H,Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) DOUBLE PRECISION H,Y,Z,HH,YY,A,B IF(NDIM-3)4,1,1 1 IF(H)2,5,2 2 HH=.5D0/H YY=Y(NDIM-2) B=Y(2)+Y(2) B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1)) DO 3 I=3,NDIM A=B B=HH*(Y(I)-Y(I-2)) 3 Z(I-2)=A IER=0 A=Y(NDIM-1)+Y(NDIM-1) Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY) Z(NDIM-1)=B RETURN 4 IER=-1 RETURN 5 IER=1 RETURN END SUBROUTINE DDET5(H,Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) DOUBLE PRECISION H,Y,Z,HH,YY,A,B,C IF(NDIM-5)4,1,1 1 IF(H)2,5,2 2 HH=.08333333333333333D0/H YY=Y(NDIM-4) B=HH*(-25.D0*Y(1)+48.D0*Y(2)-36.D0*Y(3)+16.D0*Y(4)-3.D0*Y(5)) C=HH*(-3.D0*Y(1)-10.D0*Y(2)+18.D0*Y(3)-6.D0*Y(4)+Y(5)) DO 3 I=5,NDIM A=B B=C C=HH*(Y(I-4)-Y(I)+8.D0*(Y(I-1)-Y(I-3))) 3 Z(I-4)=A IER=0 0A=HH*(-YY+6.D0*Y(NDIM-3)-18.D0*Y(NDIM-2)+10.D0*Y(NDIM-1) 1 +3.D0*Y(NDIM)) 0Z(NDIM)=HH*(3.D0*YY-16.D0*Y(NDIM-3)+36.D0*Y(NDIM-2) 1 -48.D0*Y(NDIM-1)+25.D0*Y(NDIM)) Z(NDIM-1)=A Z(NDIM-2)=C Z(NDIM-3)=B RETURN 4 IER=-1 RETURN 5 IER=1 RETURN END SUBROUTINE DGELB(R,A,M,N,MUD,MLD,EPS,IER) DIMENSION R(1),A(1) DOUBLE PRECISION R,A,PIV,TB,TOL IF(MLD)47,1,1 1 IF(MUD)47,2,2 2 MC=1+MLD+MUD IF(MC+1-M-M)3,3,47 3 IF(MC-M)5,5,4 4 MC=M 5 MU=MC-MUD-1 ML=MC-MLD-1 MR=M-ML MZ=(MU*(MU+1))/2 MA=M*MC-(ML*(ML+1))/2 NM=N*M IER=0 PIV=0.D0 IF(MLD)14,14,6 6 JJ=MA J=MA-MZ KST=J DO 9 K=1,KST TB=A(J) A(JJ)=TB TB=DABS(TB) IF(TB-PIV)8,8,7 7 PIV=TB 8 J=J-1 9 JJ=JJ-1 IF(MZ)14,14,10 10 JJ=1 J=1+MZ IC=1+MUD DO 13 I=1,MU DO 12 K=1,MC A(JJ)=0.D0 IF(K-IC)11,11,12 11 A(JJ)=A(J) J=J+1 12 JJ=JJ+1 13 IC=IC+1 14 TOL=EPS*PIV KST=1 IDST=MC IC=MC-1 DO 38 K=1,M IF(K-MR-1)16,16,15 15 IDST=IDST-1 16 ID=IDST ILR=K+MLD IF(ILR-M)18,18,17 17 ILR=M 18 II=KST PIV=0.D0 DO 22 I=K,ILR TB=DABS(A(II)) IF(TB-PIV)20,20,19 19 PIV=TB J=I JJ=II 20 IF(I-MR)22,22,21 21 ID=ID-1 22 II=II+ID IF(PIV)47,47,23 23 IF(IER)26,24,26 24 IF(PIV-TOL)25,25,26 25 IER=K-1 26 PIV=1.D0/A(JJ) ID=J-K DO 27 I=K,NM,M II=I+ID TB=PIV*R(II) R(II)=R(I) 27 R(I)=TB II=KST J=JJ+IC DO 28 I=JJ,J TB=PIV*A(I) A(I)=A(II) A(II)=TB 28 II=II+1 IF(K-ILR)29,34,34 29 ID=KST II=K+1 MU=KST+1 MZ=KST+IC DO 33 I=II,ILR ID=ID+MC JJ=I-MR-1 IF(JJ)31,31,30 30 ID=ID-JJ 31 PIV=-A(ID) J=ID+1 DO 32 JJ=MU,MZ A(J-1)=A(J)+PIV*A(JJ) 32 J=J+1 A(J-1)=0.D0 J=K DO 33 JJ=I,NM,M R(JJ)=R(JJ)+PIV*R(J) 33 J=J+M 34 KST=KST+MC IF(ILR-MR)36,35,35 35 IC=IC-1 36 ID=K-MR IF(ID)38,38,37 37 KST=KST-ID 38 CONTINUE IF(MC-1)46,46,39 39 IC=2 KST=MA+ML-MC+2 II=M DO 45 I=2,M KST=KST-MC II=II-1 J=II-MR IF(J)41,41,40 40 KST=KST+J 41 DO 43 J=II,NM,M TB=R(J) MZ=KST+IC-2 ID=J DO 42 JJ=KST,MZ ID=ID+1 42 TB=TB-A(JJ)*R(ID) 43 R(J)=TB IF(IC-MC)44,45,45 44 IC=IC+1 45 CONTINUE 46 RETURN 47 IER=-1 RETURN END SUBROUTINE DGELG(R,A,M,N,EPS,IER) DIMENSION A(1),R(1) DOUBLE PRECISION R,A,PIV,TB,TOL,PIVI IF(M)23,23,1 1 IER=0 PIV=0.D0 MM=M*M NM=N*M DO 3 L=1,MM TB=DABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L 3 CONTINUE TOL=EPS*PIV LST=1 DO 17 K=1,M IF(PIV)23,23,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 PIVI=1.D0/A(I) J=(I-1)/M I=I-J*M-K J=J+1-K DO 8 L=K,NM,M LL=L+I TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB IF(K-M)9,18,18 9 LEND=LST+M-K IF(J)12,12,10 10 II=J*M DO 11 L=LST,LEND TB=A(L) LL=L+II A(L)=A(LL) 11 A(LL)=TB 12 DO 13 L=LST,MM,M LL=L+I TB=PIVI*A(LL) A(LL)=A(L) 13 A(L)=TB A(LST)=J PIV=0.D0 LST=LST+1 J=0 DO 16 II=LST,LEND PIVI=-A(II) IST=II+M J=J+1 DO 15 L=IST,MM,M LL=L-J A(L)=A(L)+PIVI*A(LL) TB=DABS(A(L)) IF(TB-PIV)15,15,14 14 PIV=TB I=L 15 CONTINUE DO 16 L=K,NM,M LL=L+J 16 R(LL)=R(LL)+PIVI*R(L) 17 LST=LST+M 18 IF(M-1)23,22,19 19 IST=MM+M LST=M+1 DO 21 I=2,M II=LST-I IST=IST-LST L=IST-M L=A(L)+.5D0 DO 21 J=II,NM,M TB=R(J) LL=J DO 20 K=IST,MM,M LL=LL+1 20 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 21 R(K)=TB 22 RETURN 23 IER=-1 RETURN END SUBROUTINE DGELS(R,A,M,N,EPS,IER,AUX) DIMENSION A(1),R(1),AUX(1) DOUBLE PRECISION R,A,AUX,PIV,TB,TOL,PIVI IF(M)24,24,1 1 IER=0 PIV=0.D0 L=0 DO 3 K=1,M L=L+K TB=DABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L J=K 3 CONTINUE TOL=EPS*PIV LST=0 NM=N*M LEND=M-1 DO 18 K=1,M IF(PIV)24,24,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 LT=J-K LST=LST+K PIVI=1.D0/A(I) DO 8 L=K,NM,M LL=L+LT TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB IF(K-M)9,19,19 9 LR=LST+(LT*(K+J-1))/2 LL=LR L=LST DO 14 II=K,LEND L=L+II LL=LL+1 IF(L-LR)12,10,11 10 A(LL)=A(LST) TB=A(L) GO TO 13 11 LL=L+LT 12 TB=A(LL) A(LL)=A(L) 13 AUX(II)=TB 14 A(L)=PIVI*TB A(LST)=LT PIV=0.D0 LLST=LST LT=0 DO 18 II=K,LEND PIVI=-AUX(II) LL=LLST LT=LT+1 DO 15 LLD=II,LEND LL=LL+LLD L=LL+LT 15 A(L)=A(L)+PIVI*A(LL) LLST=LLST+II LR=LLST+LT TB=DABS(A(LR)) IF(TB-PIV)17,17,16 16 PIV=TB I=LR J=II+1 17 DO 18 LR=K,NM,M LL=LR+LT 18 R(LL)=R(LL)+PIVI*R(LR) 19 IF(LEND)24,23,20 20 II=M DO 22 I=2,M LST=LST-II II=II-1 L=A(LST)+.5D0 DO 22 J=II,NM,M TB=R(J) LL=J K=LST DO 21 LT=II,LEND LL=LL+1 K=K+LT 21 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 22 R(K)=TB 23 RETURN 24 IER=-1 RETURN END SUBROUTINE DELI1(RES,X,CK) DOUBLE PRECISION RES,X,CK,ANGLE,GEO,ARI,PIM,SQGEO,AARI,TEST IF(X)2,1,2 1 RES=0.D0 RETURN 2 IF(CK)4,3,4 3 RES=DLOG(DABS(X)+DSQRT(1.D0+X*X)) GOTO 13 4 ANGLE=DABS(1.D0/X) GEO=DABS(CK) ARI=1.D0 PIM=0.D0 5 SQGEO=ARI*GEO AARI=ARI ARI=GEO+ARI ANGLE=-SQGEO/ANGLE+ANGLE SQGEO=DSQRT(SQGEO) IF(ANGLE)7,6,7 6 ANGLE=SQGEO*1.D-17 7 TEST=AARI*1.D-9 IF(DABS(AARI-GEO)-TEST)10,10,8 8 GEO=SQGEO+SQGEO PIM=PIM+PIM IF(ANGLE)9,5,5 9 PIM=PIM+3.1415926535897932 GOTO 5 10 IF(ANGLE)11,12,12 11 PIM=PIM+3.1415926535897932 12 RES=(DATAN(ARI/ANGLE)+PIM)/ARI 13 IF(X)14,15,15 14 RES=-RES 15 RETURN END SUBROUTINE DELI2(R,X,CK,A,B) DOUBLE PRECISION R,X,A,B,AN,AA,ANG,AANG,PIM,PIMA,ARI,AARI DOUBLE PRECISION GEO,SGEO,C,D,P,CK IF(X)2,1,2 1 R=0.D0 RETURN 2 C=0.D0 D=0.5D0 IF(CK)7,3,7 3 R=DSQRT(1.D0+X*X) R=(A-B)*DABS(X)/R+B*DLOG(DABS(X)+R) 4 R=R+C*(A-B) IF(X)5,6,6 5 R=-R 6 RETURN 7 AN=(B+A)*0.5D0 AA=A R=B ANG=DABS(1.D0/X) PIM=0.D0 ISI=0 ARI=1.D0 GEO=DABS(CK) 8 R=AA*GEO+R SGEO=ARI*GEO AA=AN AARI=ARI ARI=GEO+ARI AN=(R/ARI+AA)*0.5D0 AANG=DABS(ANG) ANG=-SGEO/ANG+ANG PIMA=PIM IF(ANG)10,9,11 9 ANG=-1.D-17*AANG 10 PIM=PIM+3.1415926535897932 ISI=ISI+1 11 AANG=ARI*ARI+ANG*ANG P=D/DSQRT(AANG) IF(ISI-4)13,12,12 12 ISI=ISI-4 13 IF(ISI-2)15,14,14 14 P=-P 15 C=C+P D=D*(AARI-GEO)*0.5D0/ARI IF(DABS(AARI-GEO)-1.D-9*AARI)17,17,16 16 SGEO=DSQRT(SGEO) GEO=SGEO+SGEO PIM=PIM+PIMA ISI=ISI+ISI GOTO 8 17 R=(DATAN(ARI/ANG)+PIM)*AN/ARI C=C+D*ANG/AANG GOTO 4 END SUBROUTINE DLEP(Y,X,N) DIMENSION Y(1) DOUBLE PRECISION Y,X,G Y(1)=1.D0 IF(N)1,1,2 1 RETURN 2 Y(2)=X IF(N-1)1,1,3 3 DO 4 I=2,N G=X*Y(I) 4 Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/DFLOAT(I) RETURN END SUBROUTINE DLEPS(Y,X,C,N) DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2 IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1.D0 H1=X DO 4 I=2,N H2=X*H1 H2=H2-H0+H2-(H2-H0)/DFLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END SUBROUTINE DET3(H,Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) IF(NDIM-3)4,1,1 1 IF(H)2,5,2 2 HH=.5/H YY=Y(NDIM-2) B=Y(2)+Y(2) B=HH*(B+B-Y(3)-Y(1)-Y(1)-Y(1)) DO 3 I=3,NDIM A=B B=HH*(Y(I)-Y(I-2)) 3 Z(I-2)=A IER=0 A=Y(NDIM-1)+Y(NDIM-1) Z(NDIM)=HH*(Y(NDIM)+Y(NDIM)+Y(NDIM)-A-A+YY) Z(NDIM-1)=B RETURN 4 IER=-1 RETURN 5 IER=1 RETURN END SUBROUTINE DET5(H,Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) IF(NDIM-5)4,1,1 1 IF(H)2,5,2 2 HH=.08333333/H YY=Y(NDIM-4) B=HH*(-25.*Y(1)+48.*Y(2)-36.*Y(3)+16.*Y(4)-3.*Y(5)) C=HH*(-3.*Y(1)-10.*Y(2)+18.*Y(3)-6.*Y(4)+Y(5)) DO 3 I=5,NDIM A=B B=C C=HH*(Y(I-4)-Y(I)+8.*(Y(I-1)-Y(I-3))) 3 Z(I-4)=A IER=0 A=HH*(-YY+6.*Y(NDIM-3)-18.*Y(NDIM-2)+10.*Y(NDIM-1)+3.*Y(NDIM)) 0Z(NDIM)=HH*(3.*YY-16.*Y(NDIM-3)+36.*Y(NDIM-2)-48.*Y(NDIM-1) 1 +25.*Y(NDIM)) Z(NDIM-1)=A Z(NDIM-2)=C Z(NDIM-3)=B RETURN 4 IER=-1 RETURN 5 IER=1 RETURN END SUBROUTINE DSE13(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C IF(NDIM-3)3,1,1 1 B=.16666666666666667D0*(5.D0*Y(1)+Y(2)+Y(2)-Y(3)) C=.16666666666666667*(5.D0*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2)) DO 2 I=3,NDIM A=B B=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-2)=A Z(NDIM-1)=B Z(NDIM)=C IER=0 RETURN 3 IER=-1 RETURN END SUBROUTINE DSE15(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C IF(NDIM-5)3,1,1 1 A=Y(1)+Y(1) C=Y(2)+Y(2) B=.2D0*(A+Y(1)+C+Y(3)-Y(5)) C=.1D0*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4)) DO 2 I=5,NDIM A=B B=C C=.2D0*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-4)=A A=Y(NDIM)+Y(NDIM) 0A=.1D0*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2) 1 +Y(NDIM-3)) Z(NDIM-3)=B Z(NDIM-2)=C Z(NDIM-1)=A Z(NDIM)=A+A-C IER=0 RETURN 3 IER=-1 RETURN END SUBROUTINE DFMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) DIMENSION X(1),G(1),H(1) DOUBLE PRECISION X,G,GNRM,H,HNRM,F,FX,FY,OLDF,OLDG,SNRM,AMBDA, 1ALFA,DALFA,T,Z,W,DX,DY CALL FUNCT(N,X,F,G) KOUNT=0 IER=0 N1=N+1 1 DO 43 II=1,N1 KOUNT=KOUNT+1 OLDF=F GNRM=0.D0 DO 2 J=1,N 2 GNRM=GNRM+G(J)*G(J) IF(GNRM)46,46,3 3 IF(II-1)4,4,6 4 DO 5 J=1,N 5 H(J)=-G(J) GO TO 8 6 AMBDA=GNRM/OLDG DO 7 J=1,N 7 H(J)=AMBDA*H(J)-G(J) 8 DY=0.D0 HNRM=0.D0 DO 9 J=1,N K=J+N H(K)=X(J) HNRM=HNRM+DABS(H(J)) 9 DY=DY+H(J)*G(J) IF(DY)10,42,42 10 SNRM=1.D0/HNRM FY=F ALFA=2.D0*(EST-F)/DY AMBDA=SNRM IF(ALFA)13,13,11 11 IF(ALFA-AMBDA)12,13,13 12 AMBDA=ALFA 13 ALFA=0.D0 14 FX=FY DX=DY DO 15 I=1,N 15 X(I)=X(I)+AMBDA*H(I) CALL FUNCT(N,X,F,G) FY=F DY=0.D0 DO 16 I=1,N 16 DY=DY+G(I)*H(I) IF(DY)17,38,20 17 IF(FY-FX)18,20,20 18 AMBDA=AMBDA+ALFA ALFA=AMBDA IF(HNRM*AMBDA-1.D10)14,14,19 19 IER=2 F=OLDF DO 100 J=1,N G(J)=H(J) K=N+J 100 X(J)=H(K) RETURN 20 T=0. 21 IF(AMBDA)22,38,22 22 Z=3.D0*(FX-FY)/AMBDA+DX+DY ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)23,27,27 23 DO 24 J=1,N K=N+J 24 X(J)=H(K) CALL FUNCT(N,X,F,G) 25 IF(IER)47,26,47 26 IER=-1 GOTO 1 27 W=ALFA*DSQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA)270,271,270 270 ALFA=(DY-Z+W)/ALFA GO TO 272 271 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 272 ALFA=ALFA*AMBDA DO 28 I=1,N 28 X(I)=X(I)+(T-ALFA)*H(I) CALL FUNCT(N,X,F,G) IF(F-FX)29,29,30 29 IF(F-FY)38,38,30 30 DALFA=0.D0 DO 31 I=1,N 31 DALFA=DALFA+G(I)*H(I) IF(DALFA)32,35,35 32 IF(F-FX)34,33,35 33 IF(DX-DALFA)34,38,34 34 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 21 35 IF(FY-F)37,36,37 36 IF(DY-DALFA)37,38,37 37 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 20 38 IF(OLDF-F+EPS)19,25,39 39 OLDG=GNRM T=0.D0 DO 40 J=1,N K=J+N H(K)=X(J)-H(K) 40 T=T+DABS(H(K)) IF(KOUNT-N1)42,41,41 41 IF(T-EPS)45,45,42 42 IF(KOUNT-LIMIT)43,44,44 43 IER=0 GO TO 1 44 IER=1 IF(GNRM-EPS)46,46,47 45 IF(GNRM-EPS)46,46,25 46 IER=0 47 RETURN END SUBROUTINE DFMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) DIMENSION H(1),X(1),G(1) DOUBLE PRECISION X,F,FX,FY,OLDF,HNRM,GNRM,H,G,DX,DY,ALFA,DALFA, 1AMBDA,T,Z,W CALL FUNCT(N,X,F,G) IER=0 KOUNT=0 N2=N+N N3=N2+N N31=N3+1 1 K=N31 DO 4 J=1,N H(K)=1.D0 NJ=N-J IF(NJ)5,5,2 2 DO 3 L=1,NJ KL=K+L 3 H(KL)=0.D0 4 K=KL+1 5 KOUNT=KOUNT +1 OLDF=F DO 9 J=1,N K=N+J H(K)=G(J) K=K+N H(K)=X(J) K=J+N3 T=0.D0 DO 8 L=1,N T=T-G(L)*H(K) IF(L-J)6,7,7 6 K=K+N-L GO TO 8 7 K=K+1 8 CONTINUE 9 H(J)=T DY=0.D0 HNRM=0.D0 GNRM=0.D0 DO 10 J=1,N HNRM=HNRM+DABS(H(J)) GNRM=GNRM+DABS(G(J)) 10 DY=DY+H(J)*G(J) IF(DY)11,51,51 11 IF(HNRM/GNRM-EPS)51,51,12 12 FY=F ALFA=2.D0*(EST-F)/DY AMBDA=1.D0 IF(ALFA)15,15,13 13 IF(ALFA-AMBDA)14,15,15 14 AMBDA=ALFA 15 ALFA=0.D0 16 FX=FY DX=DY DO 17 I=1,N 17 X(I)=X(I)+AMBDA*H(I) CALL FUNCT(N,X,F,G) FY=F DY=0.D0 DO 18 I=1,N 18 DY=DY+G(I)*H(I) IF(DY)19,36,22 19 IF(FY-FX)20,22,22 20 AMBDA=AMBDA+ALFA ALFA=AMBDA IF(HNRM*AMBDA-1.D10)16,16,21 21 IER=2 RETURN 22 T=0.D0 23 IF(AMBDA)24,36,24 24 Z=3.D0*(FX-FY)/AMBDA+DX+DY ALFA=DMAX1(DABS(Z),DABS(DX),DABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)51,25,25 25 W=ALFA*DSQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA) 250,251,250 250 ALFA=(DY-Z+W)/ALFA GO TO 252 251 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 252 ALFA=ALFA*AMBDA DO 26 I=1,N 26 X(I)=X(I)+(T-ALFA)*H(I) CALL FUNCT(N,X,F,G) IF(F-FX)27,27,28 27 IF(F-FY)36,36,28 28 DALFA=0.D0 DO 29 I=1,N 29 DALFA=DALFA+G(I)*H(I) IF(DALFA)30,33,33 30 IF(F-FX)32,31,33 31 IF(DX-DALFA)32,36,32 32 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 23 33 IF(FY-F)35,34,35 34 IF(DY-DALFA)35,36,35 35 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 22 36 IF(OLDF-F+EPS)51,38,38 38 DO 37 J=1,N K=N+J H(K)=G(J)-H(K) K=N+K 37 H(K)=X(J)-H(K) IER=0 IF(KOUNT-N)42,39,39 39 T=0.D0 Z=0.D0 DO 40 J=1,N K=N+J W=H(K) K=K+N T=T+DABS(H(K)) 40 Z=Z+W*H(K) IF(HNRM-EPS)41,41,42 41 IF(T-EPS)56,56,42 42 IF(KOUNT-LIMIT)43,50,50 43 ALFA=0.D0 DO 47 J=1,N K=J+N3 W=0.D0 DO 46 L=1,N KL=N+L W=W+H(KL)*H(K) IF(L-J)44,45,45 44 K=K+N-L GO TO 46 45 K=K+1 46 CONTINUE K=N+J ALFA=ALFA+W*H(K) 47 H(J)=W IF(Z*ALFA)48,1,48 48 K=N31 DO 49 L=1,N KL=N2+L DO 49 J=L,N NJ=N2+J H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA 49 K=K+1 GO TO 5 50 IER=1 RETURN 51 DO 52 J=1,N K=N2+J 52 X(J)=H(K) CALL FUNCT(N,X,F,G) IF(GNRM-EPS)55,55,53 53 IF(IER)56,54,54 54 IER=-1 GOTO 1 55 IER=0 56 RETURN END SUBROUTINE DFRAT(I,N,M,P,DATI,WGT,IER) DIMENSION P(1),DATI(1),IER(1) DOUBLE PRECISION P,DATI,WGT,T,F,FNUM,FDEN IP=IER(2) IQ=IER(3) IQM1=IQ-1 IPQ=IP+IQ T=DATI(I) J=I+N F=DATI(J) FNUM=P(J) J=J+N WGT=1.D0 IF(DATI(2*N+1))2,2,1 1 WGT=DATI(J) 2 FDEN=P(J) F=F*FDEN-FNUM IF(FDEN)4,3,4 3 IER(1)=1 RETURN 4 WGT=WGT/(FDEN*FDEN) FNUM=-FNUM/FDEN J=IQM1 IF(IP-IQ)6,6,5 5 J=IP-1 6 CALL DCNP(P(IQ),T,J) 7 IF(IQM1)10,10,8 8 DO 9 II=1,IQM1 J=II+IQ 9 P(II)=P(J)*FNUM 10 P(IPQ)=F IER(1)=0 RETURN END SUBROUTINE DGT3(X,Y,Z,NDIM,IER) DIMENSION X(1),Y(1),Z(1) IER=-1 IF(NDIM-3)8,1,1 1 A=X(1) B=Y(1) I=2 DY2=X(2)-A IF(DY2)2,9,2 2 DY2=(Y(2)-B)/DY2 DO 6 I=3,NDIM A=X(I)-A IF(A)3,9,3 3 A=(Y(I)-B)/A B=X(I)-X(I-1) IF(B)4,9,4 4 DY1=DY2 DY2=(Y(I)-Y(I-1))/B DY3=A A=X(I-1) B=Y(I-1) IF(I-3)5,5,6 5 Z(1)=DY1+DY3-DY2 6 Z(I-1)=DY1+DY2-DY3 IER=0 I=NDIM 7 Z(I)=DY2+DY3-DY1 8 RETURN 9 IER=I I=I-1 IF(I-2)8,8,7 END SUBROUTINE DQG12(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.49078031712335963D0*B Y=.23587668193255914D-1*(FCT(A+C)+FCT(A-C)) C=.45205862818523743D0*B Y=Y+.53469662997659215D-1*(FCT(A+C)+FCT(A-C)) C=.38495133709715234D0*B Y=Y+.8003916427167311D-1*(FCT(A+C)+FCT(A-C)) C=.29365897714330872D0*B Y=Y+.10158371336153296D0*(FCT(A+C)+FCT(A-C)) C=.18391574949909010D0*B Y=Y+.11674626826917740D0*(FCT(A+C)+FCT(A-C)) C=.62616704255734458D-1*B Y=B*(Y+.12457352290670139D0*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DQG16(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.49470046749582497D0*B Y=.13576229705877047D-1*(FCT(A+C)+FCT(A-C)) C=.47228751153661629D0*B Y=Y+.31126761969323946D-1*(FCT(A+C)+FCT(A-C)) C=.43281560119391587D0*B Y=Y+.47579255841246392D-1*(FCT(A+C)+FCT(A-C)) C=.37770220417750152D0*B Y=Y+.62314485627766936D-1*(FCT(A+C)+FCT(A-C)) C=.30893812220132187D0*B Y=Y+.7479799440828837D-1*(FCT(A+C)+FCT(A-C)) C=.22900838882861369D0*B Y=Y+.8457825969750127D-1*(FCT(A+C)+FCT(A-C)) C=.14080177538962946D0*B Y=Y+.9130170752246179D-1*(FCT(A+C)+FCT(A-C)) C=.47506254918818720D-1*B Y=B*(Y+.9472530522753425D-1*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DQG24(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.49759360999851068D0*B Y=.61706148999935998D-2*(FCT(A+C)+FCT(A-C)) C=.48736427798565475D0*B Y=Y+.14265694314466832D-1*(FCT(A+C)+FCT(A-C)) C=.46913727600136638D0*B Y=Y+.22138719408709903D-1*(FCT(A+C)+FCT(A-C)) C=.44320776350220052D0*B Y=Y+.29649292457718390D-1*(FCT(A+C)+FCT(A-C)) C=.41000099298695146D0*B Y=Y+.36673240705540153D-1*(FCT(A+C)+FCT(A-C)) C=.37006209578927718D0*B Y=Y+.43095080765976638D-1*(FCT(A+C)+FCT(A-C)) C=.32404682596848778D0*B Y=Y+.48809326052056944D-1*(FCT(A+C)+FCT(A-C)) C=.27271073569441977D0*B Y=Y+.53722135057982817D-1*(FCT(A+C)+FCT(A-C)) C=.21689675381302257D0*B Y=Y+.57752834026862801D-1*(FCT(A+C)+FCT(A-C)) C=.15752133984808169D0*B Y=Y+.60835236463901696D-1*(FCT(A+C)+FCT(A-C)) C=.9555943373680815D-1*B Y=Y+.62918728173414148D-1*(FCT(A+C)+FCT(A-C)) C=.32028446431302813D-1*B Y=B*(Y+.63969097673376078D-1*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DQG32(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.49863193092474078D0*B Y=.35093050047350483D-2*(FCT(A+C)+FCT(A-C)) C=.49280575577263417D0*B Y=Y+.8137197365452835D-2*(FCT(A+C)+FCT(A-C)) C=.48238112779375322D0*B Y=Y+.12696032654631030D-1*(FCT(A+C)+FCT(A-C)) C=.46745303796886984D0*B Y=Y+.17136931456510717D-1*(FCT(A+C)+FCT(A-C)) C=.44816057788302606D0*B Y=Y+.21417949011113340D-1*(FCT(A+C)+FCT(A-C)) C=.42468380686628499D0*B Y=Y+.25499029631188088D-1*(FCT(A+C)+FCT(A-C)) C=.39724189798397120D0*B Y=Y+.29342046739267774D-1*(FCT(A+C)+FCT(A-C)) C=.36609105937014484D0*B Y=Y+.32911111388180923D-1*(FCT(A+C)+FCT(A-C)) C=.33152213346510760D0*B Y=Y+.36172897054424253D-1*(FCT(A+C)+FCT(A-C)) C=.29385787862038116D0*B Y=Y+.39096947893535153D-1*(FCT(A+C)+FCT(A-C)) C=.25344995446611470D0*B Y=Y+.41655962113473378D-1*(FCT(A+C)+FCT(A-C)) C=.21067563806531767D0*B Y=Y+.43826046502201906D-1*(FCT(A+C)+FCT(A-C)) C=.16593430114106382D0*B Y=Y+.45586939347881942D-1*(FCT(A+C)+FCT(A-C)) C=.11964368112606854D0*B Y=Y+.46922199540402283D-1*(FCT(A+C)+FCT(A-C)) C=.7223598079139825D-1*B Y=Y+.47819360039637430D-1*(FCT(A+C)+FCT(A-C)) C=.24153832843869158D-1*B Y=B*(Y+.48270044257363900D-1*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DHARM(A,M,INV,S,IFSET,IFERR) DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2) DOUBLE PRECISION A,R,W3,AWI,THETA,ROOT2,S,T,W,W2,FN,AWR EQUIVALENCE (N1,N(1)),(N2,N(2)),(N3,N(3)) 10 IF( IABS(IFSET) - 1) 900,900,12 12 MTT=MAX0(M(1),M(2),M(3)) -2 ROOT2=DSQRT(2.0D0) IF (MTT-MT ) 14,14,13 13 IFERR=1 RETURN 14 IFERR=0 M1=M(1) M2=M(2) M3=M(3) N1=2**M1 N2=2**M2 N3=2**M3 16 IF(IFSET) 18,18,20 18 NX= N1*N2*N3 FN = NX DO 19 I = 1,NX A(2*I-1) = A(2*I-1)/FN 19 A(2*I) = -A(2*I)/FN 20 NP(1)=N1*2 NP(2)= NP(1)*N2 NP(3)=NP(2)*N3 DO 250 ID=1,3 IL = NP(3)-NP(ID) IL1 = IL+1 MI = M(ID) IF (MI)250,250,30 30 IDIF=NP(ID) KBIT=NP(ID) MEV = 2*(MI/2) IF (MI - MEV )60,60,40 40 KBIT=KBIT/2 KL=KBIT-2 DO 50 I=1,IL1,IDIF KLAST=KL+I DO 50 K=I,KLAST,2 KD=K+KBIT T=A(KD) A(KD)=A(K)-T A(K)=A(K)+T T=A(KD+1) A(KD+1)=A(K+1)-T 50 A(K+1)=A(K+1)+T IF (MI - 1)250,250,52 52 LFIRST =3 JLAST=1 GO TO 70 60 LFIRST = 2 JLAST=0 70 DO 240 L=LFIRST,MI,2 JJDIF=KBIT KBIT=KBIT/4 KL=KBIT-2 DO 80 I=1,IL1,IDIF KLAST=I+KL DO 80 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT T=A(K2) A(K2)=A(K)-T A(K)=A(K)+T T=A(K2+1) A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T T=A(K3) A(K3)=A(K1)-T A(K1)=A(K1)+T T=A(K3+1) A(K3+1)=A(K1+1)-T A(K1+1)=A(K1+1)+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T = A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 80 A(K2+1)=A(K2+1)+T IF (JLAST) 235,235,82 82 JJ=JJDIF +1 ILAST= IL +JJ DO 85 I = JJ,ILAST,IDIF KLAST = KL+I DO 85 K=I,KLAST,2 K1 = K+KBIT K2 = K1+KBIT K3 = K2+KBIT R =-A(K2+1) T = A(K2) A(K2) = A(K)-R A(K) = A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T AWR=A(K1)-A(K1+1) AWI = A(K1+1)+A(K1) R=-A(K3)-A(K3+1) T=A(K3)-A(K3+1) A(K3)=(AWR-R)/ROOT2 A(K3+1)=(AWI-T)/ROOT2 A(K1)=(AWR+R)/ROOT2 A(K1+1)=(AWI+T)/ROOT2 T= A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 85 A(K2+1)=A(K2+1)+T IF(JLAST-1) 235,235,90 90 JJ= JJ + JJDIF DO 230 J=2,JLAST 96 I=INV(J+1) 98 IC=NT-I W(1)=S(IC) W(2)=S(I) I2=2*I I2C=NT-I2 IF(I2C)120,110,100 100 W2(1)=S(I2C) W2(2)=S(I2) GO TO 130 110 W2(1)=0. W2(2)=1. GO TO 130 120 I2CC = I2C+NT I2C=-I2C W2(1)=-S(I2C) W2(2)=S(I2CC) 130 I3=I+I2 I3C=NT-I3 IF(I3C)160,150,140 140 W3(1)=S(I3C) W3(2)=S(I3) GO TO 200 150 W3(1)=0. W3(2)=1. GO TO 200 160 I3CC=I3C+NT IF(I3CC)190,180,170 170 I3C=-I3C W3(1)=-S(I3C) W3(2)=S(I3CC) GO TO 200 180 W3(1)=-1. W3(2)=0. GO TO 200 190 I3CCC=NT+I3CC I3CC = -I3CC W3(1)=-S(I3CCC) W3(2)=-S(I3CC) 200 ILAST=IL+JJ DO 220 I=JJ,ILAST,IDIF KLAST=KL+I DO 220 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT R=A(K2)*W2(1)-A(K2+1)*W2(2) T=A(K2)*W2(2)+A(K2+1)*W2(1) A(K2)=A(K)-R A(K)=A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T R=A(K3)*W3(1)-A(K3+1)*W3(2) T=A(K3)*W3(2)+A(K3+1)*W3(1) AWR=A(K1)*W(1)-A(K1+1)*W(2) AWI=A(K1)*W(2)+A(K1+1)*W(1) A(K3)=AWR-R A(K3+1)=AWI-T A(K1)=AWR+R A(K1+1)=AWI+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 220 A(K2+1)=A(K2+1)+T 230 JJ=JJDIF+JJ 235 JLAST=4*JLAST+3 240 CONTINUE 250 CONTINUE NTSQ=NT*NT M3MT=M3-MT 350 IF(M3MT) 370,360,360 360 IGO3=1 N3VNT=N3/NT MINN3=NT GO TO 380 370 IGO3=2 N3VNT=1 NTVN3=NT/N3 MINN3=N3 380 JJD3 = NTSQ/N3 M2MT=M2-MT 450 IF (M2MT)470,460,460 460 IGO2=1 N2VNT=N2/NT MINN2=NT GO TO 480 470 IGO2 = 2 N2VNT=1 NTVN2=NT/N2 MINN2=N2 480 JJD2=NTSQ/N2 M1MT=M1-MT 550 IF(M1MT)570,560,560 560 IGO1=1 N1VNT=N1/NT MINN1=NT GO TO 580 570 IGO1=2 N1VNT=1 NTVN1=NT/N1 MINN1=N1 580 JJD1=NTSQ/N1 600 JJ3=1 J=1 DO 880 JPP3=1,N3VNT IPP3=INV(JJ3) DO 870 JP3=1,MINN3 GO TO (610,620),IGO3 610 IP3=INV(JP3)*N3VNT GO TO 630 620 IP3=INV(JP3)/NTVN3 630 I3=(IPP3+IP3)*N2 700 JJ2=1 DO 870 JPP2=1,N2VNT IPP2=INV(JJ2)+I3 DO 860 JP2=1,MINN2 GO TO (710,720),IGO2 710 IP2=INV(JP2)*N2VNT GO TO 730 720 IP2=INV(JP2)/NTVN2 730 I2=(IPP2+IP2)*N1 800 JJ1=1 DO 860 JPP1=1,N1VNT IPP1=INV(JJ1)+I2 DO 850 JP1=1,MINN1 GO TO (810,820),IGO1 810 IP1=INV(JP1)*N1VNT GO TO 830 820 IP1=INV(JP1)/NTVN1 830 I=2*(IPP1+IP1)+1 IF (J-I) 840,850,850 840 T=A(I) A(I)=A(J) A(J)=T T=A(I+1) A(I+1)=A(J+1) A(J+1)=T 850 J=J+2 860 JJ1=JJ1+JJD1 870 JJ2=JJ2+JJD2 880 JJ3 = JJ3+JJD3 890 IF(IFSET)891,895,895 891 DO 892 I = 1,NX 892 A(2*I) = -A(2*I) 895 RETURN 900 MT=MAX0(M(1),M(2),M(3)) -2 MT = MAX0(2,MT) 904 IF (MT-18) 906,906,13 906 IFERR=0 NT=2**MT NTV2=NT/2 910 THETA=.7853981633974483 JSTEP=NT JDIF=NTV2 S(JDIF)=DSIN(THETA) DO 950 L=2,MT THETA=THETA/2.0D0 JSTEP2=JSTEP JSTEP=JDIF JDIF=JSTEP/2 S(JDIF)=DSIN(THETA) JC1=NT-JDIF S(JC1)=DCOS(THETA) JLAST=NT-JSTEP2 IF(JLAST - JSTEP) 950,920,920 920 DO 940 J=JSTEP,JLAST,JSTEP JC=NT-J JD=J+JDIF 940 S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC) 950 CONTINUE 960 MTLEXP=NTV2 LM1EXP=1 INV(1)=0 DO 980 L=1,MT INV(LM1EXP+1) = MTLEXP DO 970 J=2,LM1EXP JJ=J+LM1EXP 970 INV(JJ)=INV(J)+MTLEXP MTLEXP=MTLEXP/2 980 LM1EXP=LM1EXP*2 982 IF(IFSET)12,895,12 END SUBROUTINE DHPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1) DOUBLE PRECISION Y,DERY,AUX,PRMT,X,H,Z,DELT N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0.D0 DO 1 I=1,NDIM AUX(16,I)=0.D0 AUX(15,I)=DERY(I) 1 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))3,2,4 2 IHLF=12 GOTO 4 3 IHLF=13 4 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,5,6 5 IF(IHLF)7,7,6 6 RETURN 7 DO 8 I=1,NDIM 8 AUX(8,I)=DERY(I) ISW=1 GOTO 100 9 X=X+H DO 10 I=1,NDIM 10 AUX(2,I)=Y(I) 11 IHLF=IHLF+1 X=X-H DO 12 I=1,NDIM 12 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW=2 GOTO 100 13 X=X+H CALL FCT(X,Y,DERY) N=2 DO 14 I=1,NDIM AUX(2,I)=Y(I) 14 AUX(9,I)=DERY(I) ISW=3 GOTO 100 15 DELT=0.D0 DO 16 I=1,NDIM 16 DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I)) DELT=.066666666666666667D0*DELT IF(DELT-PRMT(4))19,19,17 17 IF(IHLF-10)11,18,18 18 IHLF=11 X=X+H GOTO 4 19 X=X+H CALL FCT(X,Y,DERY) DO 20 I=1,NDIM AUX(3,I)=Y(I) 20 AUX(10,I)=DERY(I) N=3 ISW=4 GOTO 100 21 N=1 X=X+H CALL FCT(X,Y,DERY) X=PRMT(1) DO 22 I=1,NDIM AUX(11,I)=DERY(I) 220Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 23 X=X+H N=N+1 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,24,6 24 IF(N-4)25,200,200 25 DO 26 I=1,NDIM AUX(N,I)=Y(I) 26 AUX(N+7,I)=DERY(I) IF(N-3)27,29,200 27 DO 28 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 28 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 23 29 DO 30 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 30 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 23 100 DO 101 I=1,NDIM Z=H*AUX(N+7,I) AUX(5,I)=Z 101 Y(I)=AUX(N,I)+.4D0*Z Z=X+.4D0*H CALL FCT(Z,Y,DERY) DO 102 I=1,NDIM Z=H*DERY(I) AUX(6,I)=Z 102 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*Z Z=X+.45573725421878943D0*H CALL FCT(Z,Y,DERY) DO 103 I=1,NDIM Z=H*DERY(I) AUX(7,I)=Z 103 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*Z Z=X+H CALL FCT(Z,Y,DERY) DO 104 I=1,NDIM 1040Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) GOTO(9,13,15,21),ISW 200 ISTEP=3 201 IF(N-8)204,202,204 202 DO 203 N=2,7 DO 203 I=1,NDIM AUX(N-1,I)=AUX(N,I) 203 AUX(N+6,I)=AUX(N+7,I) N=7 204 N=N+1 DO 205 I=1,NDIM AUX(N-1,I)=Y(I) 205 AUX(N+6,I)=DERY(I) X=X+H 206 ISTEP=ISTEP+1 DO 207 I=1,NDIM 0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 207 AUX(16,I)=DELT CALL FCT(X,Y,DERY) DO 208 I=1,NDIM 0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 208 Y(I)=DELT+.07438016528925620D0*AUX(16,I) DELT=0.D0 DO 209 I=1,NDIM 209 DELT=DELT+AUX(15,I)*DABS(AUX(16,I)) IF(DELT-PRMT(4))210,222,222 210 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))212,211,212 211 IF(IHLF-11)213,212,212 212 RETURN 213 IF(H*(X-PRMT(2)))214,212,212 214 IF(DABS(X-PRMT(2))-.1D0*DABS(H))212,215,215 215 IF(DELT-.02D0*PRMT(4))216,216,201 216 IF(IHLF)201,201,217 217 IF(N-7)201,218,218 218 IF(ISTEP-4)201,219,219 219 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)201,220,201 220 H=H+H IHLF=IHLF-1 ISTEP=0 DO 221 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 2210AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 201 222 IHLF=IHLF+1 IF(IHLF-10)223,223,210 223 H=.5D0*H ISTEP=0 DO 224 I=1,NDIM 0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 224 AUX(N+4,I)=AUX(N+5,I) X=X-H DELT=X-(H+H) CALL FCT(DELT,Y,DERY) DO 225 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 225 Y(I)=AUX(N-4,I) DELT=DELT-(H+H) CALL FCT(DELT,Y,DERY) DO 226 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 226 AUX(N+3,I)=DERY(I) GOTO 206 END SUBROUTINE DHPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1) DOUBLE PRECISION PRMT,Y,DERY,AUX,X,H,Z,DELT,A,HS GOTO 100 1 CALL AFCT(X,A) CALL FCT(X,DERY) DO 3 M=1,NDIM LL=M-NDIM HS=0.D0 DO 2 L=1,NDIM LL=LL+NDIM 2 HS=HS+A(LL)*Y(L) 3 DERY(M)=HS+DERY(M) GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2 100 N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0.D0 DO 101 I=1,NDIM AUX(16,I)=0.D0 AUX(15,I)=DERY(I) 101 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))103,102,104 102 IHLF=12 GOTO 104 103 IHLF=13 104 ISW2=1 GOTO 1 105 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,106,107 106 IF(IHLF)108,108,107 107 RETURN 108 DO 109 I=1,NDIM 109 AUX(8,I)=DERY(I) ISW1=1 GOTO 200 110 X=X+H DO 111 I=1,NDIM 111 AUX(2,I)=Y(I) 112 IHLF=IHLF+1 X=X-H DO 113 I=1,NDIM 113 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW1=2 GOTO 200 114 X=X+H ISW2=5 GOTO 1 115 N=2 DO 116 I=1,NDIM AUX(2,I)=Y(I) 116 AUX(9,I)=DERY(I) ISW1=3 GOTO 200 117 DELT=0.D0 DO 118 I=1,NDIM 118 DELT=DELT+AUX(15,I)*DABS(Y(I)-AUX(4,I)) DELT=.066666666666666667D0*DELT IF(DELT-PRMT(4))121,121,119 119 IF(IHLF-10)112,120,120 120 IHLF=11 X=X+H GOTO 104 121 X=X+H ISW2=6 GOTO 1 122 DO 123 I=1,NDIM AUX(3,I)=Y(I) 123 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 200 124 N=1 X=X+H ISW2=7 GOTO 1 125 X=PRMT(1) DO 126 I=1,NDIM AUX(11,I)=DERY(I) 1260Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 127 X=X+H N=N+1 ISW2=12 GOTO 1 128 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,129,107 129 IF(N-4)130,300,300 130 DO 131 I=1,NDIM AUX(N,I)=Y(I) 131 AUX(N+7,I)=DERY(I) IF(N-3)132,134,300 132 DO 133 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 133 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 127 134 DO 135 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 135 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 127 200 Z=X DO 201 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 201 Y(I)=AUX(N,I)+.4D0*X X=Z+.4D0*H ISW2=2 GOTO 1 202 DO 203 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 203 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X X=Z+.45573725421878943D0*H ISW2=3 GOTO 1 204 DO 205 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 205 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*X X=Z+H ISW2=4 GOTO 1 206 DO 207 I=1,NDIM 2070Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) X=Z GOTO(110,114,117,124),ISW1 300 ISTEP=3 301 IF(N-8)304,302,304 302 DO 303 N=2,7 DO 303 I=1,NDIM AUX(N-1,I)=AUX(N,I) 303 AUX(N+6,I)=AUX(N+7,I) N=7 304 N=N+1 DO 305 I=1,NDIM AUX(N-1,I)=Y(I) 305 AUX(N+6,I)=DERY(I) X=X+H 306 ISTEP=ISTEP+1 DO 307 I=1,NDIM 0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 307 AUX(16,I)=DELT ISW2=8 GOTO 1 308 DO 309 I=1,NDIM 0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 309 Y(I)=DELT+.07438016528925620D0*AUX(16,I) DELT=0.D0 DO 310 I=1,NDIM 310 DELT=DELT+AUX(15,I)*DABS(AUX(16,I)) IF(DELT-PRMT(4))311,324,324 311 ISW2=9 GOTO 1 312 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))314,313,314 313 IF(IHLF-11)315,314,314 314 RETURN 315 IF(H*(X-PRMT(2)))316,314,314 316 IF(DABS(X-PRMT(2))-.1D0*DABS(H))314,317,317 317 IF(DELT-.02D0*PRMT(4))318,318,301 318 IF(IHLF)301,301,319 319 IF(N-7)301,320,320 320 IF(ISTEP-4)301,321,321 321 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)301,322,301 322 H=H+H IHLF=IHLF-1 ISTEP=0 DO 323 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 3230AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 301 324 IHLF=IHLF+1 IF(IHLF-10)325,325,311 325 H=.5D0*H ISTEP=0 DO 326 I=1,NDIM 0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 326 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=10 GOTO 1 327 DO 328 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 328 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=11 GOTO 1 329 X=DELT DO 330 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 330 AUX(N+3,I)=DERY(I) GOTO 306 END SUBROUTINE DHEP(Y,X,N) DIMENSION Y(1) DOUBLE PRECISION Y,X,F Y(1)=1.D0 IF(N)1,1,2 1 RETURN 2 Y(2)=X+X IF(N-1)1,1,3 3 DO 4 I=2,N F=X*Y(I)-DFLOAT(I-1)*Y(I-1) 4 Y(I+1)=F+F RETURN END SUBROUTINE DHEPS(Y,X,C,N) DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2 IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1.D0 H1=X+X DO 4 I=2,N H2=X*H1-DFLOAT(I-1)*H0 H0=H1 H1=H2+H2 4 Y=Y+C(I)*H0 RETURN END SUBROUTINE DQHSG(X,Y,FDY,SDY,Z,NDIM) DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1) DOUBLE PRECISION X,Y,FDY,SDY,Z,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5D0*(X(I)-X(I-1)) 0SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4D0*SUM2*((FDY(I-1)-FDY(I))+ 1 .16666666666666667D0*SUM2*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DQH16(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.46887389393058184D1 Z=-X Y=.26548074740111822D-9*(FCT(X)+FCT(Z)) X=.38694479048601227D1 Z=-X Y=Y+.23209808448652107D-6*(FCT(X)+FCT(Z)) X=.31769991619799560D1 Z=-X Y=Y+.27118600925378815D-4*(FCT(X)+FCT(Z)) X=.25462021578474814D1 Z=-X Y=Y+.9322840086241805D-3*(FCT(X)+FCT(Z)) X=.19517879909162540D1 Z=-X Y=Y+.12880311535509974D-1*(FCT(X)+FCT(Z)) X=.13802585391988808D1 Z=-X Y=Y+.8381004139898583D-1*(FCT(X)+FCT(Z)) X=.8229514491446559D0 Z=-X Y=Y+.28064745852853368D0*(FCT(X)+FCT(Z)) X=.27348104613815245D0 Z=-X Y=Y+.50792947901661374D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DQH24(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.60159255614257397D1 Z=-X Y=.16643684964891089D-15*(FCT(X)+FCT(Z)) X=.52593829276680444D1 Z=-X Y=Y+.65846202430781701D-12*(FCT(X)+FCT(Z)) X=.46256627564237873D1 Z=-X Y=Y+.30462542699875639D-9*(FCT(X)+FCT(Z)) X=.40536644024481495D1 Z=-X Y=Y+.40189711749414297D-7*(FCT(X)+FCT(Z)) X=.35200068130345247D1 Z=-X Y=Y+.21582457049023336D-5*(FCT(X)+FCT(Z)) X=.30125461375655648D1 Z=-X Y=Y+.56886916364043798D-4*(FCT(X)+FCT(Z)) X=.25238810170114270D1 Z=-X Y=Y+.8236924826884175D-3*(FCT(X)+FCT(Z)) X=.20490035736616989D1 Z=-X Y=Y+.70483558100726710D-2*(FCT(X)+FCT(Z)) X=.15842500109616941D1 Z=-X Y=Y+.37445470503230746D-1*(FCT(X)+FCT(Z)) X=.11267608176112451D1 Z=-X Y=Y+.12773962178455916D0*(FCT(X)+FCT(Z)) X=.67417110703721224D0 Z=-X Y=Y+.28617953534644302D0*(FCT(X)+FCT(Z)) X=.22441454747251559D0 Z=-X Y=Y+.42693116386869925D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DQH32(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.71258139098307276D1 Z=-X Y=.7310676427384162D-22*(FCT(X)+FCT(Z)) X=.64094981492696604D1 Z=-X Y=Y+.9231736536518292D-18*(FCT(X)+FCT(Z)) X=.58122259495159138D1 Z=-X Y=Y+.11973440170928487D-14*(FCT(X)+FCT(Z)) X=.52755509865158801D1 Z=-X Y=Y+.42150102113264476D-12*(FCT(X)+FCT(Z)) X=.47771645035025964D1 Z=-X Y=Y+.59332914633966386D-10*(FCT(X)+FCT(Z)) X=.43055479533511984D1 Z=-X Y=Y+.40988321647708966D-8*(FCT(X)+FCT(Z)) X=.38537554854714446D1 Z=-X Y=Y+.15741677925455940D-6*(FCT(X)+FCT(Z)) X=.34171674928185707D1 Z=-X Y=Y+.36505851295623761D-5*(FCT(X)+FCT(Z)) X=.29924908250023742D1 Z=-X Y=Y+.54165840618199826D-4*(FCT(X)+FCT(Z)) X=.25772495377323175D1 Z=-X Y=Y+.53626836552797205D-3*(FCT(X)+FCT(Z)) X=.21694991836061122D1 Z=-X Y=Y+.36548903266544281D-2*(FCT(X)+FCT(Z)) X=.17676541094632016D1 Z=-X Y=Y+.17553428831573430D-1*(FCT(X)+FCT(Z)) X=.13703764109528718D1 Z=-X Y=Y+.60458130955912614D-1*(FCT(X)+FCT(Z)) X=.9765004635896828D0 Z=-X Y=Y+.15126973407664248D0*(FCT(X)+FCT(Z)) X=.58497876543593245D0 Z=-X Y=Y+.27745814230252990D0*(FCT(X)+FCT(Z)) X=.19484074156939933D0 Z=-X Y=Y+.37523835259280239D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DQH48(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.8975315081931687D1 Z=-X Y=.7935551460773997D-35*(FCT(X)+FCT(Z)) X=.8310752190704784D1 Z=-X Y=Y+.59846126933138784D-30*(FCT(X)+FCT(Z)) X=.7759295519765775D1 Z=-X Y=Y+.36850360801506699D-26*(FCT(X)+FCT(Z)) X=.7266046554164350D1 Z=-X Y=Y+.55645774689022848D-23*(FCT(X)+FCT(Z)) X=.68100645780741414D1 Z=-X Y=Y+.31883873235051384D-20*(FCT(X)+FCT(Z)) X=.63805640961864106D1 Z=-X Y=Y+.8730159601186677D-18*(FCT(X)+FCT(Z)) X=.59710722250135454D1 Z=-X Y=Y+.13151596226584085D-15*(FCT(X)+FCT(Z)) X=.55773169812237286D1 Z=-X Y=Y+.11975898654791794D-13*(FCT(X)+FCT(Z)) X=.51962877187923645D1 Z=-X Y=Y+.70469325815458891D-12*(FCT(X)+FCT(Z)) X=.48257572281332095D1 Z=-X Y=Y+.28152965378381691D-10*(FCT(X)+FCT(Z)) X=.44640145469344589D1 Z=-X Y=Y+.7930467495165382D-9*(FCT(X)+FCT(Z)) X=.41097046035605902D1 Z=-X Y=Y+.16225141358957698D-7*(FCT(X)+FCT(Z)) X=.37617264902283578D1 Z=-X Y=Y+.24686589936697505D-6*(FCT(X)+FCT(Z)) X=.34191659693638846D1 Z=-X Y=Y+.28472586917348481D-5*(FCT(X)+FCT(Z)) X=.30812489886451058D1 Z=-X Y=Y+.25285990277484889D-4*(FCT(X)+FCT(Z)) X=.27473086248223832D1 Z=-X Y=Y+.17515043180117283D-3*(FCT(X)+FCT(Z)) X=.24167609048732165D1 Z=-X Y=Y+.9563923198194153D-3*(FCT(X)+FCT(Z)) X=.20890866609442764D1 Z=-X Y=Y+.41530049119775525D-2*(FCT(X)+FCT(Z)) X=.17638175798953000D1 Z=-X Y=Y+.14444961574981099D-1*(FCT(X)+FCT(Z)) X=.14405252201375652D1 Z=-X Y=Y+.40479676984603849D-1*(FCT(X)+FCT(Z)) X=.11188121524021566D1 Z=-X Y=Y+.9182229707928518D-1*(FCT(X)+FCT(Z)) X=.7983046277785622D0 Z=-X Y=Y+.16920447194564111D0*(FCT(X)+FCT(Z)) X=.47864633759449610D0 Z=-X Y=Y+.25396154266475910D0*(FCT(X)+FCT(Z)) X=.15949293584886247D0 Z=-X Y=Y+.31100103037796308D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DQH64(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.10526123167960546D2 Z=-X C Y=.55357065358569428D-48*(FCT(X)+FCT(Z)) Y=0 X=.9895287586829539D1 Z=-X C Y=Y+.16797479901081592D-42*(FCT(X)+FCT(Z)) X=.9373159549646721D1 Z=-X Y=Y+.34211380112557405D-38*(FCT(X)+FCT(Z)) X=.8907249099964770D1 Z=-X Y=Y+.15573906246297638D-34*(FCT(X)+FCT(Z)) X=.8477529083379863D1 Z=-X Y=Y+.25496608991129993D-31*(FCT(X)+FCT(Z)) X=.8073687285010225D1 Z=-X Y=Y+.19291035954649669D-28*(FCT(X)+FCT(Z)) X=.7689540164040497D1 Z=-X Y=Y+.7861797788925910D-26*(FCT(X)+FCT(Z)) X=.7321013032780949D1 Z=-X Y=Y+.19117068833006428D-23*(FCT(X)+FCT(Z)) X=.69652411205511075D1 Z=-X Y=Y+.29828627842798512D-21*(FCT(X)+FCT(Z)) X=.66201122626360274D1 Z=-X Y=Y+.31522545665037814D-19*(FCT(X)+FCT(Z)) X=.62840112287748282D1 Z=-X Y=Y+.23518847106758191D-17*(FCT(X)+FCT(Z)) X=.59556663267994860D1 Z=-X Y=Y+.12800933913224380D-15*(FCT(X)+FCT(Z)) X=.56340521643499721D1 Z=-X Y=Y+.52186237265908475D-14*(FCT(X)+FCT(Z)) X=.53183252246332709D1 Z=-X Y=Y+.16283407307097204D-12*(FCT(X)+FCT(Z)) X=.50077796021987682D1 Z=-X Y=Y+.39591777669477239D-11*(FCT(X)+FCT(Z)) X=.47018156474074998D1 Z=-X Y=Y+.7615217250145451D-10*(FCT(X)+FCT(Z)) X=.43999171682281376D1 Z=-X Y=Y+.11736167423215493D-8*(FCT(X)+FCT(Z)) X=.41016344745666567D1 Z=-X Y=Y+.14651253164761094D-7*(FCT(X)+FCT(Z)) X=.38065715139453605D1 Z=-X Y=Y+.14955329367272471D-6*(FCT(X)+FCT(Z)) X=.35143759357409062D1 Z=-X Y=Y+.12583402510311846D-5*(FCT(X)+FCT(Z)) X=.32247312919920357D1 Z=-X Y=Y+.8788499230850359D-5*(FCT(X)+FCT(Z)) X=.29373508230046218D1 Z=-X Y=Y+.51259291357862747D-4*(FCT(X)+FCT(Z)) X=.26519724354306350D1 Z=-X Y=Y+.25098369851306249D-3*(FCT(X)+FCT(Z)) X=.23683545886324014D1 Z=-X Y=Y+.10363290995075777D-2*(FCT(X)+FCT(Z)) X=.20862728798817620D1 Z=-X Y=Y+.36225869785344588D-2*(FCT(X)+FCT(Z)) X=.18055171714655449D1 Z=-X Y=Y+.10756040509879137D-1*(FCT(X)+FCT(Z)) X=.15258891402098637D1 Z=-X Y=Y+.27203128953688918D-1*(FCT(X)+FCT(Z)) X=.12472001569431179D1 Z=-X Y=Y+.58739981964099435D-1*(FCT(X)+FCT(Z)) X=.9692694230711780D0 Z=-X Y=Y+.10849834930618684D0*(FCT(X)+FCT(Z)) X=.69192230581004458D0 Z=-X Y=Y+.17168584234908370D0*(FCT(X)+FCT(Z)) X=.41498882412107868D0 Z=-X Y=Y+.23299478606267805D0*(FCT(X)+FCT(Z)) X=.13830224498700972D0 Z=-X Y=Y+.27137742494130398D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DISCR (K,M,N,X,XBAR,D,CMEAN,V,C,P,LG) DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1),C(1),P(1),LG(1) N1=N(1) DO 100 I=2,K 100 N1=N1+N(I) FNT=N1 DO 110 I=1,K 110 P(I)=N(I) DO 130 I=1,M CMEAN(I)=0 N1=I-M DO 120 J=1,K N1=N1+M 120 CMEAN(I)=CMEAN(I)+P(J)*XBAR(N1) 130 CMEAN(I)=CMEAN(I)/FNT L=0 DO 140 I=1,K DO 140 J=1,M L=L+1 140 C(L)=XBAR(L)-CMEAN(J) V=0.0 L=0 DO 160 J=1,M DO 160 I=1,M N1=I-M N2=J-M SUM=0.0 DO 150 IJ=1,K N1=N1+M N2=N2+M 150 SUM=SUM+P(IJ)*C(N1)*C(N2) L=L+1 160 V=V+D(L)*SUM N2=0 DO 190 KA=1,K DO 170 I=1,M N2=N2+1 170 P(I)=XBAR(N2) IQ=(M+1)*(KA-1)+1 SUM=0.0 DO 180 J=1,M N1=J-M DO 180 L=1,M N1=N1+M 180 SUM=SUM+D(N1)*P(J)*P(L) C(IQ)=-(SUM/2.0) DO 190 I=1,M N1=I-M IQ=IQ+1 C(IQ)=0.0 DO 190 J=1,M N1=N1+M 190 C(IQ)=C(IQ)+D(N1)*P(J) LBASE=0 N1=0 DO 270 KG=1,K NN=N(KG) DO 260 I=1,NN L=I-NN+LBASE DO 200 J=1,M L=L+NN 200 D(J)=X(L) N2=0 DO 220 KA=1,K N2=N2+1 SUM=C(N2) DO 210 J=1,M N2=N2+1 210 SUM=SUM+C(N2)*D(J) 220 XBAR(KA)=SUM L=1 SUM=XBAR(1) DO 240 J=2,K IF(SUM-XBAR(J)) 230, 240, 240 230 L=J SUM=XBAR(J) 240 CONTINUE PL=0.0 DO 250 J=1,K 250 PL=PL+ EXP(XBAR(J)-SUM) N1=N1+1 LG(N1)=L 260 P(N1)=1.0/PL 270 LBASE=LBASE+NN*M RETURN END SUBROUTINE DJELF(SN,CN,DN,X,SCK) DIMENSION ARI(12),GEO(12) DOUBLE PRECISION SN,CN,DN,X,SCK,ARI,GEO,CM,Y,A,B,C,D CM=SCK Y=X IF(SCK)3,1,4 1 D=DEXP(X) A=1.D0/D B=A+D CN=2.D0/B DN=CN A=(D-A)/2.D0 SN=A*CN 2 RETURN 3 D=1.D0-SCK CM=-SCK/D D=DSQRT(D) Y=D*X 4 A=1.D0 DN=1.D0 DO 6 I=1,12 L=I ARI(I)=A CM=DSQRT(CM) GEO(I)=CM C=(A+CM)*.5D0 IF(DABS(A-CM)-1.D-9*A)7,7,5 5 CM=A*CM 6 A=C 7 Y=C*Y SN=DSIN(Y) CN=DCOS(Y) IF(SN)8,13,8 8 A=CN/SN C=A*C DO 9 I=1,L K=L-I+1 B=ARI(K) A=C*A C=DN*C DN=(GEO(K)+A)/(B+A) 9 A=C/B A=1.D0/DSQRT(C*C+1.D0) IF(SN)10,11,11 10 SN=-A GOTO 12 11 SN=A 12 CN=C*SN 13 IF(SCK)14,2,2 14 A=DN DN=CN CN=A SN=SN/D RETURN END 0SUBROUTINE DLBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, 1AUX,A) DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1) DOUBLE PRECISION PRMT,B,C,R,Y,DERY,AUX,A,H,X,Z,GL,HS,GU,SUM, 1DGL,DGU,XST,XEND,DELT IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3 1 IHLF=12 RETURN 2 IHLF=13 RETURN 3 KK=-NDIM IB=0 IC=0 DO 7 K=1,NDIM AUX(15,K)=DERY(K) AUX(1,K)=1.D0 AUX(17,K)=1.D0 KK=KK+NDIM DO 4 I=1,NDIM II=KK+I IF(B(II))5,4,5 4 CONTINUE IB=IB+1 AUX(1,K)=0.D0 5 DO 6 I=1,NDIM II=KK+I IF(C(II))7,6,7 6 CONTINUE IC=IC+1 AUX(17,K)=0.D0 7 CONTINUE IF(IC-IB)8,11,11 8 H=PRMT(2) PRMT(2)=PRMT(1) PRMT(1)=H PRMT(3)=-PRMT(3) DO 9 I=1,NDIM 9 AUX(17,I)=AUX(1,I) II=NDIM*NDIM DO 10 I=1,II H=B(I) B(I)=C(I) 10 C(I)=H 11 X=PRMT(2) CALL FCT(X,Y) CALL DFCT(X,DERY) DO 12 I=1,NDIM AUX(18,I)=Y(I) 12 AUX(19,I)=DERY(I) K=0 KK=0 100 K=K+1 IF(AUX(17,K))108,108,101 101 X=PRMT(2) CALL AFCT(X,A) SUM=0.D0 GL=AUX(18,K) DGL=AUX(19,K) II=K DO 104 I=1,NDIM H=-A(II) DERY(I)=H AUX(20,I)=R(I) Y(I)=0.D0 IF(I-K)103,102,103 102 Y(I)=1.D0 103 DGL=DGL+H*AUX(18,I) 104 II=II+NDIM XEND=PRMT(1) H=.0625D0*(XEND-X) ISW=0 GOTO 400 105 IF(IHLF-10)106,106,117 106 DO 107 I=1,NDIM KK=KK+1 H=C(KK) R(I)=AUX(20,I)+H*SUM II=I DO 107 J=1,NDIM B(II)=B(II)+H*Y(J) 107 II=II+NDIM GOTO 109 108 KK=KK+NDIM 109 IF(K-NDIM)100,110,110 110 EPS=PRMT(4) CALL DGELG(R,B,NDIM,1,EPS,I) IF(I)111,112,112 111 IHLF=14 RETURN 112 PRMT(5)=0.D0 IHLF=-I X=PRMT(1) XEND=PRMT(2) H=PRMT(3) DO 113 I=1,NDIM 113 Y(I)=R(I) ISW=1 114 ISW2=12 GOTO 200 115 ISW3=-1 GOTO 300 116 IF(IHLF)400,400,117 117 RETURN 200 CALL AFCT(X,A) IF(ISW)201,201,205 201 LL=0 DO 203 M=1,NDIM HS=0.D0 DO 202 L=1,NDIM LL=LL+1 202 HS=HS-A(LL)*Y(L) 203 DERY(M)=HS 204 GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2 205 CALL FCT(X,DERY) DO 207 M=1,NDIM LL=M-NDIM HS=0.D0 DO 206 L=1,NDIM LL=LL+NDIM 206 HS=HS+A(LL)*Y(L) 207 DERY(M)=HS+DERY(M) GOTO 204 300 IF(ISW)301,301,305 301 CALL FCT(X,R) GU=0.D0 DGU=0.D0 DO 302 L=1,NDIM GU=GU+Y(L)*R(L) 302 DGU=DGU+DERY(L)*R(L) CALL DFCT(X,R) DO 303 L=1,NDIM 303 DGU=DGU+Y(L)*R(L) SUM=SUM+.5D0*H*((GL+GU)+.16666666666666667D0*H*(DGL-DGU)) GL=GU DGL=DGU 304 IF(ISW3)116,422,618 305 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))117,304,117 400 N=1 XST=X IHLF=0 DO 401 I=1,NDIM AUX(16,I)=0.D0 AUX(1,I)=Y(I) 401 AUX(8,I)=DERY(I) ISW1=1 GOTO 500 402 X=X+H DO 403 I=1,NDIM 403 AUX(2,I)=Y(I) 404 IHLF=IHLF+1 X=X-H DO 405 I=1,NDIM 405 AUX(4,I)=AUX(2,I) H=.5D0*H N=1 ISW1=2 GOTO 500 406 X=X+H ISW2=4 GOTO 200 407 N=2 DO 408 I=1,NDIM AUX(2,I)=Y(I) 408 AUX(9,I)=DERY(I) ISW1=3 GOTO 500 409 DO 414 I=1,NDIM Z=DABS(Y(I)) IF(Z-1.D0)410,411,411 410 Z=1.D0 411 DELT=.066666666666666667D0*DABS(Y(I)-AUX(4,I)) IF(ISW)413,413,412 412 DELT=AUX(15,I)*DELT 413 IF(DELT-Z*PRMT(4))414,414,429 414 CONTINUE X=X+H ISW2=5 GOTO 200 415 DO 416 I=1,NDIM AUX(3,I)=Y(I) 416 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 500 417 N=1 X=X+H ISW2=6 GOTO 200 418 X=XST DO 419 I=1,NDIM AUX(11,I)=DERY(I) 4190Y(I)=AUX(1,I)+H*(.375D0*AUX(8,I)+.7916666666666667D0*AUX(9,I) 1-.20833333333333333D0*AUX(10,I)+.041666666666666667D0*DERY(I)) 420 X=X+H N=N+1 ISW2=11 GOTO 200 421 ISW3=0 GOTO 300 422 IF(N-4)423,600,600 423 DO 424 I=1,NDIM AUX(N,I)=Y(I) 424 AUX(N+7,I)=DERY(I) IF(N-3)425,427,600 425 DO 426 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 426 Y(I)=AUX(1,I)+.33333333333333333D0*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 420 427 DO 428 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 428 Y(I)=AUX(1,I)+.375D0*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 420 429 IF(IHLF-10)404,430,430 430 IHLF=11 X=X+H IF(ISW)105,105,114 500 Z=X DO 501 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 501 Y(I)=AUX(N,I)+.4D0*X X=Z+.4D0*H ISW2=1 GOTO 200 502 DO 503 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 503 Y(I)=AUX(N,I)+.29697760924775360D0*AUX(5,I)+.15875964497103583D0*X X=Z+.45573725421878943D0*H ISW2=2 GOTO 200 504 DO 505 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 505 Y(I)=AUX(N,I)+.21810038822592047D0*AUX(5,I)-3.0509651486929308D0* 1AUX(6,I)+3.8328647604670103D0*X X=Z+H ISW2=3 GOTO 200 506 DO 507 I=1,NDIM 5070Y(I)=AUX(N,I)+.17476028226269037D0*AUX(5,I)-.55148066287873294D0* 1AUX(6,I)+1.2055355993965235D0*AUX(7,I)+.17118478121951903D0* 2H*DERY(I) X=Z GOTO(402,406,409,417),ISW1 600 ISTEP=3 601 IF(N-8)604,602,604 602 DO 603 N=2,7 DO 603 I=1,NDIM AUX(N-1,I)=AUX(N,I) 603 AUX(N+6,I)=AUX(N+7,I) N=7 604 N=N+1 DO 605 I=1,NDIM AUX(N-1,I)=Y(I) 605 AUX(N+6,I)=DERY(I) X=X+H 606 ISTEP=ISTEP+1 DO 607 I=1,NDIM 0DELT=AUX(N-4,I)+1.3333333333333333D0*H*(AUX(N+6,I)+AUX(N+6,I)- 1AUX(N+5,I)+AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198347107438D0*AUX(16,I) 607 AUX(16,I)=DELT ISW2=7 GOTO 200 608 DO 609 I=1,NDIM 0DELT=.125D0*(9.D0*AUX(N-1,I)-AUX(N-3,I)+3.D0*H*(DERY(I)+AUX(N+6,I) 1+AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 609 Y(I)=DELT+.07438016528925620D0*AUX(16,I) DELT=0.D0 DO 616 I=1,NDIM Z=DABS(Y(I)) IF(Z-1.D0)610,611,611 610 Z=1.D0 611 Z=DABS(AUX(16,I))/Z IF(ISW)613,613,612 612 Z=AUX(15,I)*Z 613 IF(Z-PRMT(4))614,614,628 614 IF(DELT-Z)615,616,616 615 DELT=Z 616 CONTINUE ISW2=8 GOTO 200 617 ISW3=1 GOTO 300 618 IF(H*(X-XEND))619,621,621 619 IF(DABS(X-XEND)-.1D0*DABS(H))621,620,620 620 IF(DELT-.02D0*PRMT(4))622,622,601 621 IF(ISW)105,105,117 622 IF(IHLF)601,601,623 623 IF(N-7)601,624,624 624 IF(ISTEP-4)601,625,625 625 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)601,626,601 626 H=H+H IHLF=IHLF-1 ISTEP=0 DO 627 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 6270AUX(16,I)=8.962962962962963D0*(Y(I)-AUX(N-3,I)) 1-3.3611111111111111D0*H*(DERY(I)+DELT+AUX(N+4,I)) GOTO 601 628 IHLF=IHLF+1 IF(IHLF-10)630,630,629 629 IF(ISW)105,105,114 630 H=.5D0*H ISTEP=0 DO 631 I=1,NDIM 0Y(I)=.390625D-2*(8.D1*AUX(N-1,I)+135.D0*AUX(N-2,I)+4.D1*AUX(N-3,I) 1+AUX(N-4,I))-.1171875D0*(AUX(N+6,I)-6.D0*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.390625D-2*(12.D0*AUX(N-1,I)+135.D0*AUX(N-2,I)+ 1108.D0*AUX(N-3,I)+AUX(N-4,I))-.0234375D0*(AUX(N+6,I)+ 218.D0*AUX(N+5,I)-9.D0*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 631 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=9 GOTO 200 632 DO 633 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 633 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=10 GOTO 200 634 X=DELT DO 635 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962962962962963D0*(AUX(N-1,I)-Y(I)) 1-3.3611111111111111D0*H*(AUX(N+6,I)+DELT+DERY(I)) 635 AUX(N+3,I)=DERY(I) GOTO 606 END SUBROUTINE DLGAM(XX,DLNG,IER) DOUBLE PRECISION XX,ZZ,TERM,RZ2,DLNG IER=0 ZZ=XX IF(XX-1.D10) 2,2,1 1 IF(XX-1.D33) 8,9,9 2 IF(XX-1.D-9) 3,3,4 3 IER=-1 DLNG=-1.D33 GO TO 10 4 TERM=1.D0 5 IF(ZZ-18.D0) 6,6,7 6 TERM=TERM*ZZ ZZ=ZZ+1.D0 GO TO 5 7 RZ2=1.D0/ZZ**2 DLNG =(ZZ-0.5D0)*DLOG(ZZ)-ZZ +0.9189385332046727 -DLOG(TERM)+ 1(1.D0/ZZ)*(.8333333333333333D-1 -(RZ2*(.2777777777777777D-2 +(RZ2* 2(.7936507936507936D-3 -(RZ2*(.5952380952380952D-3))))))) GO TO 10 8 DLNG=ZZ*(DLOG(ZZ)-1.D0) GO TO 10 9 IER=+1 DLNG=1.D33 10 RETURN END SUBROUTINE DLLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX) DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1) DOUBLE PRECISION A,B,X,AUX,PIV,H,SIG,BETA,TOL IF(M-N)30,1,1 1 PIV=0.D0 IEND=0 DO 4 K=1,N IPIV(K)=K H=0.D0 IST=IEND+1 IEND=IEND+M DO 2 I=IST,IEND 2 H=H+A(I)*A(I) AUX(K)=H IF(H-PIV)4,4,3 3 PIV=H KPIV=K 4 CONTINUE IF(PIV)31,31,5 5 SIG=DSQRT(PIV) TOL=SIG*ABS(EPS) LM=L*M IST=-M DO 21 K=1,N IST=IST+M+1 IEND=IST+M-K I=KPIV-K IF(I)8,8,6 6 H=AUX(K) AUX(K)=AUX(KPIV) AUX(KPIV)=H ID=I*M DO 7 I=IST,IEND J=I+ID H=A(I) A(I)=A(J) 7 A(J)=H 8 IF(K-1)11,11,9 9 SIG=0.D0 DO 10 I=IST,IEND 10 SIG=SIG+A(I)*A(I) SIG=DSQRT(SIG) IF(SIG-TOL)32,32,11 11 H=A(IST) IF(H)12,13,13 12 SIG=-SIG 13 IPIV(KPIV)=IPIV(K) IPIV(K)=KPIV BETA=H+SIG A(IST)=BETA BETA=1.D0/(SIG*BETA) J=N+K AUX(J)=-SIG IF(K-N)14,19,19 14 PIV=0.D0 ID=0 JST=K+1 KPIV=JST DO 18 J=JST,N ID=ID+M H=0.D0 DO 15 I=IST,IEND II=I+ID 15 H=H+A(I)*A(II) H=BETA*H DO 16 I=IST,IEND II=I+ID 16 A(II)=A(II)-A(I)*H II=IST+ID H=AUX(J)-A(II)*A(II) AUX(J)=H IF(H-PIV)18,18,17 17 PIV=H KPIV=J 18 CONTINUE 19 DO 21 J=K,LM,M H=0.D0 IEND=J+M-K II=IST DO 20 I=J,IEND H=H+A(II)*B(I) 20 II=II+1 H=BETA*H II=IST DO 21 I=J,IEND B(I)=B(I)-A(II)*H 21 II=II+1 IER=0 I=N LN=L*N PIV=1.D0/AUX(2*N) DO 22 K=N,LN,N X(K)=PIV*B(I) 22 I=I+M IF(N-1)26,26,23 23 JST=(N-1)*M+N DO 25 J=2,N JST=JST-M-1 K=N+N+1-J PIV=1.D0/AUX(K) KST=K-N ID=IPIV(KST)-KST IST=2-J DO 25 K=1,L H=B(KST) IST=IST+N IEND=IST+J-2 II=JST DO 24 I=IST,IEND II=II+M 24 H=H-A(II)*X(I) I=IST-1 II=I+ID X(I)=X(II) X(II)=PIV*H 25 KST=KST+M 26 IST=N+1 IEND=0 DO 29 J=1,L IEND=IEND+M H=0.D0 IF(M-N)29,29,27 27 DO 28 I=IST,IEND 28 H=H+B(I)*B(I) IST=IST+M 29 AUX(J)=H RETURN 30 IER=-2 RETURN 31 IER=-1 RETURN 32 IER=K-1 RETURN END SUBROUTINE DQL12(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.37099121044466920D2 Y=.8148077467426242D-15*FCT(X) X=.28487967250984000D2 Y=Y+.30616016350350208D-11*FCT(X) X=.22151090379397006D2 Y=Y+.13423910305150041D-8*FCT(X) X=.17116855187462256D2 Y=Y+.16684938765409103D-6*FCT(X) X=.13006054993306348D2 Y=Y+.8365055856819799D-5*FCT(X) X=.9621316842456867D1 Y=Y+.20323159266299939D-3*FCT(X) X=.68445254531151773D1 Y=Y+.26639735418653159D-2*FCT(X) X=.45992276394183485D1 Y=Y+.20102381154634097D-1*FCT(X) X=.28337513377435072D1 Y=Y+.9044922221168093D-1*FCT(X) X=.15126102697764188D1 Y=Y+.24408201131987756D0*FCT(X) X=.61175748451513067D0 Y=Y+.37775927587313798D0*FCT(X) X=.11572211735802068D0 Y=Y+.26473137105544319D0*FCT(X) RETURN END SUBROUTINE DQL16(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.51701160339543318D2 Y=.41614623703728552D-21*FCT(X) X=.41940452647688333D2 Y=Y+.50504737000355128D-17*FCT(X) X=.34583398702286626D2 Y=Y+.62979670025178678D-14*FCT(X) X=.28578729742882140D2 Y=Y+.21270790332241030D-11*FCT(X) X=.23515905693991909D2 Y=Y+.28623502429738816D-9*FCT(X) X=.19180156856753135D2 Y=Y+.18810248410796732D-7*FCT(X) X=.15441527368781617D2 Y=Y+.68283193308711996D-6*FCT(X) X=.12214223368866159D2 Y=Y+.14844586873981299D-4*FCT(X) X=.9438314336391939D1 Y=Y+.20427191530827846D-3*FCT(X) X=.70703385350482341D1 Y=Y+.18490709435263109D-2*FCT(X) X=.50780186145497679D1 Y=Y+.11299900080339453D-1*FCT(X) X=.34370866338932066D1 Y=Y+.47328928694125219D-1*FCT(X) X=.21292836450983806D1 Y=Y+.13629693429637754D0*FCT(X) X=.11410577748312269D1 Y=Y+.26579577764421415D0*FCT(X) X=.46269632891508083D0 Y=Y+.33105785495088417D0*FCT(X) X=.8764941047892784D-1 Y=Y+.20615171495780099D0*FCT(X) RETURN END SUBROUTINE DQL24(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.8149827923394889D2 Y=.55753457883283568D-34*FCT(X) X=.69962240035105030D2 Y=Y+.40883015936806578D-29*FCT(X) X=.61058531447218762D2 Y=Y+.24518188458784027D-25*FCT(X) X=.53608574544695070D2 Y=Y+.36057658645529590D-22*FCT(X) X=.47153106445156323D2 Y=Y+.20105174645555035D-19*FCT(X) X=.41451720484870767D2 Y=Y+.53501888130100376D-17*FCT(X) X=.36358405801651622D2 Y=Y+.7819800382459448D-15*FCT(X) X=.31776041352374723D2 Y=Y+.68941810529580857D-13*FCT(X) X=.27635937174332717D2 Y=Y+.39177365150584514D-11*FCT(X) X=.23887329848169733D2 Y=Y+.15070082262925849D-9*FCT(X) X=.20491460082616425D2 Y=Y+.40728589875499997D-8*FCT(X) X=.17417992646508979D2 Y=Y+.7960812959133630D-7*FCT(X) X=.14642732289596674D2 Y=Y+.11513158127372799D-5*FCT(X) X=.12146102711729766D2 Y=Y+.12544721977993333D-4*FCT(X) X=.9912098015077706D1 Y=Y+.10446121465927518D-3*FCT(X) X=.7927539247172152D1 Y=Y+.67216256409354789D-3*FCT(X) X=.61815351187367654D1 Y=Y+.33693490584783036D-2*FCT(X) X=.46650837034671708D1 Y=Y+.13226019405120157D-1*FCT(X) X=.33707742642089977D1 Y=Y+.40732478151408646D-1*FCT(X) X=.22925620586321903D1 Y=Y+.9816627262991889D-1*FCT(X) X=.14255975908036131D1 Y=Y+.18332268897777802D0*FCT(X) X=.7660969055459366D0 Y=Y+.25880670727286980D0*FCT(X) X=.31123914619848373D0 Y=Y+.25877410751742390D0*FCT(X) X=.59019852181507977D-1 Y=Y+.14281197333478185D0*FCT(X) RETURN END SUBROUTINE DQL32(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.11175139809793770D3 C Y=.45105361938989742D-47*FCT(X) Y=0 X=.9882954286828397D2 C Y=Y+.13386169421062563D-41*FCT(X) X=.8873534041789240D2 Y=Y+.26715112192401370D-37*FCT(X) X=.8018744697791352D2 Y=Y+.11922487600982224D-33*FCT(X) X=.7268762809066271D2 Y=Y+.19133754944542243D-30*FCT(X) X=.65975377287935053D2 Y=Y+.14185605454630369D-27*FCT(X) X=.59892509162134018D2 Y=Y+.56612941303973594D-25*FCT(X) X=.54333721333396907D2 Y=Y+.13469825866373952D-22*FCT(X) X=.49224394987308639D2 Y=Y+.20544296737880454D-20*FCT(X) X=.44509207995754938D2 Y=Y+.21197922901636186D-18*FCT(X) X=.40145719771539442D2 Y=Y+.15421338333938234D-16*FCT(X) X=.36100494805751974D2 Y=Y+.8171823443420719D-15*FCT(X) X=.32346629153964737D2 Y=Y+.32378016577292665D-13*FCT(X) X=.28862101816323475D2 Y=Y+.9799379288727094D-12*FCT(X) X=.25628636022459248D2 Y=Y+.23058994918913361D-10*FCT(X) X=.22630889013196774D2 Y=Y+.42813829710409289D-9*FCT(X) X=.19855860940336055D2 Y=Y+.63506022266258067D-8*FCT(X) X=.17292454336715315D2 Y=Y+.7604567879120781D-7*FCT(X) X=.14931139755522557D2 Y=Y+.7416404578667552D-6*FCT(X) X=.12763697986742725D2 Y=Y+.59345416128686329D-5*FCT(X) X=.10783018632539972D2 Y=Y+.39203419679879472D-4*FCT(X) X=.8982940924212596D1 Y=Y+.21486491880136419D-3*FCT(X) X=.7358126733186241D1 Y=Y+.9808033066149551D-3*FCT(X) X=.59039585041742439D1 Y=Y+.37388162946115248D-2*FCT(X) X=.46164567697497674D1 Y=Y+.11918214834838557D-1*FCT(X) X=.34922132730219945D1 Y=Y+.31760912509175070D-1*FCT(X) X=.25283367064257949D1 Y=Y+.70578623865717442D-1*FCT(X) X=.17224087764446454D1 Y=Y+.12998378628607176D0*FCT(X) X=.10724487538178176D1 Y=Y+.19590333597288104D0*FCT(X) X=.57688462930188643D0 Y=Y+.23521322966984801D0*FCT(X) X=.23452610951961854D0 Y=Y+.21044310793881323D0*FCT(X) X=.44489365833267018D-1 Y=Y+.10921834195238497D0*FCT(X) RETURN END SUBROUTINE DMATX (K,M,N,X,XBAR,D,CMEAN) DIMENSION N(1),X(1),XBAR(1),D(1),CMEAN(1) MM=M*M DO 100 I=1,MM 100 D(I)=0.0 N4=0 L=0 LM=0 DO 160 NG=1,K N1=N(NG) FN=N1 DO 130 J=1,M LM=LM+1 XBAR(LM)=0.0 DO 120 I=1,N1 L=L+1 120 XBAR(LM)=XBAR(LM)+X(L) 130 XBAR(LM)=XBAR(LM)/FN LMEAN=LM-M DO 150 I=1,N1 LL=N4+I-N1 DO 140 J=1,M LL=LL+N1 N2=LMEAN+J 140 CMEAN(J)=X(LL)-XBAR(N2) LL=0 DO 150 J=1,M DO 150 JJ=1,M LL=LL+1 150 D(LL)=D(LL)+CMEAN(J)*CMEAN(JJ) 160 N4=N4+N1*M LL=-K DO 170 I=1,K 170 LL=LL+N(I) FN=LL DO 180 I=1,MM 180 D(I)=D(I)/FN RETURN END SUBROUTINE DMCHB(R,A,M,N,MUD,IOP,EPS,IER) DIMENSION R(1),A(1) DOUBLE PRECISION TOL,SUM,PIV,R,A IF(IABS(IOP)-3)1,1,43 1 IF(MUD)43,2,2 2 MC=MUD+1 IF(M-MC)43,3,3 3 MR=M-MUD IER=0 IF(IOP)24,4,4 4 IEND=0 LLDST=MUD DO 23 K=1,M IST=IEND+1 IEND=IST+MUD J=K-MR IF(J)6,6,5 5 IEND=IEND-J 6 IF(J-1)8,8,7 7 LLDST=LLDST-1 8 LMAX=MUD J=MC-K IF(J)10,10,9 9 LMAX=LMAX-J 10 ID=0 TOL=A(IST)*EPS DO 23 I=IST,IEND SUM=0.D0 IF(LMAX)14,14,11 11 LL=IST LLD=LLDST DO 13 L=1,LMAX LL=LL-LLD LLL=LL+ID SUM=SUM+A(LL)*A(LLL) IF(LLD-MUD)12,13,13 12 LLD=LLD+1 13 CONTINUE 14 SUM=A(I)-SUM IF(I-IST)15,15,20 15 IF(SUM)43,43,16 16 IF(SUM-TOL)17,17,19 17 IF(IER)18,18,19 18 IER=K-1 19 PIV=DSQRT(SUM) A(I)=PIV PIV=1.D0/PIV GO TO 21 20 A(I)=SUM*PIV 21 ID=ID+1 IF(ID-J)23,23,22 22 LMAX=LMAX-1 23 CONTINUE IF(IOP)24,44,24 24 ID=N*M IEND=IABS(IOP)-2 IF(IEND)25,35,25 25 IST=1 LMAX=0 J=-MR LLDST=MUD DO 34 K=1,M PIV=A(IST) IF(PIV)26,43,26 26 PIV=1.D0/PIV DO 30 I=K,ID,M SUM=0.D0 IF(LMAX)30,30,27 27 LL=IST LLL=I LLD=LLDST DO 29 L=1,LMAX LL=LL-LLD LLL=LLL-1 SUM=SUM+A(LL)*R(LLL) IF(LLD-MUD)28,29,29 28 LLD=LLD+1 29 CONTINUE 30 R(I)=PIV*(R(I)-SUM) IF(MC-K)32,32,31 31 LMAX=K 32 IST=IST+MC J=J+1 IF(J)34,34,33 33 IST=IST-J LLDST=LLDST-1 34 CONTINUE IF(IEND)35,35,44 35 IST=M+(MUD*(M+M-MC))/2+1 LMAX=0 K=M 36 IEND=IST-1 IST=IEND-LMAX PIV=A(IST) IF(PIV)37,43,37 37 PIV=1.D0/PIV L=IST+1 DO 40 I=K,ID,M SUM=0.D0 IF(LMAX)40,40,38 38 LLL=I DO 39 LL=L,IEND LLL=LLL+1 39 SUM=SUM+A(LL)*R(LLL) 40 R(I)=PIV*(R(I)-SUM) IF(K-MR)42,42,41 41 LMAX=LMAX+1 42 K=K-1 IF(K)44,44,36 43 IER=-1 44 RETURN END SUBROUTINE DMFGR(A,M,N,EPS,IRANK,IROW,ICOL) DIMENSION A(1),IROW(1),ICOL(1) DOUBLE PRECISION A,PIV,HOLD,SAVE IF(M)2,2,1 1 IF(N)2,2,4 2 IRANK=-1 3 RETURN 4 IRANK=0 PIV=0.D0 JJ=0 DO 6 J=1,N ICOL(J)=J DO 6 I=1,M JJ=JJ+1 HOLD=A(JJ) IF(DABS(PIV)-DABS(HOLD))5,6,6 5 PIV=HOLD IR=I IC=J 6 CONTINUE DO 7 I=1,M 7 IROW(I)=I TOL=ABS(EPS*SNGL(PIV)) NM=N*M DO 19 NCOL=M,NM,M 8 IF(ABS(SNGL(PIV))-TOL)20,20,9 9 IRANK=IRANK+1 JJ=IR-IRANK IF(JJ)12,12,10 10 DO 11 J=IRANK,NM,M I=J+JJ SAVE=A(J) A(J)=A(I) 11 A(I)=SAVE JJ=IROW(IR) IROW(IR)=IROW(IRANK) IROW(IRANK)=JJ 12 JJ=(IC-IRANK)*M IF(JJ)15,15,13 13 KK=NCOL DO 14 J=1,M I=KK+JJ SAVE=A(KK) A(KK)=A(I) KK=KK-1 14 A(I)=SAVE JJ=ICOL(IC) ICOL(IC)=ICOL(IRANK) ICOL(IRANK)=JJ 15 KK=IRANK+1 MM=IRANK-M LL=NCOL+MM IF(MM)16,25,25 16 JJ=LL SAVE=PIV PIV=0.D0 DO 19 J=KK,M JJ=JJ+1 HOLD=A(JJ)/SAVE A(JJ)=HOLD L=J-IRANK IF(IRANK-N)17,19,19 17 II=JJ DO 19 I=KK,N II=II+M MM=II-L A(II)=A(II)-HOLD*A(MM) IF(DABS(A(II))-DABS(PIV))19,19,18 18 PIV=A(II) IR=J IC=I 19 CONTINUE 20 IF(IRANK-1)3,25,21 21 IR=LL DO 24 J=2,IRANK II=J-1 IR=IR-M JJ=LL DO 23 I=KK,M HOLD=0.D0 JJ=JJ+1 MM=JJ IC=IR DO 22 L=1,II HOLD=HOLD+A(MM)*A(IC) IC=IC-1 22 MM=MM-M 23 A(MM)=A(MM)-HOLD 24 CONTINUE 25 IF(N-IRANK)3,3,26 26 IR=LL KK=LL+M DO 30 J=1,IRANK DO 29 I=KK,NM,M JJ=IR LL=I HOLD=0.D0 II=J 27 II=II-1 IF(II)29,29,28 28 HOLD=HOLD-A(JJ)*A(LL) JJ=JJ-M LL=LL-1 GOTO 27 29 A(LL)=(HOLD-A(LL))/A(JJ) 30 IR=IR-1 RETURN END SUBROUTINE DMLSS(A,N,IRANK,TRAC,INC,RHS,IER) DIMENSION A(1),TRAC(1),RHS(1) DOUBLE PRECISION SUM,A,RHS,TRAC,HOLD IDEF=N-IRANK IF(N)33,33,1 1 IF(IRANK)33,33,2 2 IF(IDEF)33,3,3 3 ITE=IRANK*(IRANK+1)/2 IX2=IRANK+1 NP1=N+1 IER=0 JJ=1 II=1 4 DO 6 I=1,N J=TRAC(II) IF(J)31,31,5 5 HOLD=RHS(II) RHS(II)=RHS(J) RHS(J)=HOLD 6 II=II+JJ IF(JJ)32,7,7 7 ISW=1 IF(INC*IDEF)8,28,8 8 ISTA=ITE DO 10 I=1,IRANK ISTA=ISTA+1 JJ=ISTA SUM=0.D0 DO 9 J=IX2,N SUM=SUM+A(JJ)*RHS(J) 9 JJ=JJ+J 10 RHS(I)=RHS(I)+SUM GOTO(11,28,11),ISW 11 ISTA=ITE DO 15 I=IX2,N JJ=ISTA SUM=0.D0 DO 12 J=1,IRANK JJ=JJ+1 12 SUM=SUM+A(JJ)*RHS(J) GOTO(13,13,14),ISW 13 SUM=-SUM 14 RHS(I)=SUM 15 ISTA=ISTA+I GOTO(16,29,30),ISW 16 ISTA=IX2 IEND=N JJ=ITE+ISTA 17 SUM=0.D0 DO 20 I=ISTA,IEND IF(A(JJ))18,31,18 18 RHS(I)=(RHS(I)-SUM)/A(JJ) IF(I-IEND)19,21,21 19 JJ=JJ+ISTA SUM=0.D0 DO 20 J=ISTA,I SUM=SUM+A(JJ)*RHS(J) 20 JJ=JJ+1 21 SUM=0.D0 II=IEND DO 24 I=ISTA,IEND RHS(II)=(RHS(II)-SUM)/A(JJ) IF(II-ISTA)25,25,22 22 KK=JJ-1 SUM=0.D0 DO 23 J=II,IEND SUM=SUM+A(KK)*RHS(J) 23 KK=KK+J JJ=JJ-II 24 II=II-1 25 IF(IDEF)26,30,26 26 GOTO(27,11,8),ISW 27 ISW=2 GOTO 8 28 ISTA=1 IEND=IRANK JJ=1 ISW=2 GOTO 17 29 ISW=3 GOTO 16 30 II=N JJ=-1 GOTO 4 31 IER=1 32 RETURN 33 IER=-1 RETURN END SUBROUTINE DMPRC(A,M,N,ITRA,INV,IROCO,IER) DIMENSION A(1),ITRA(1) DOUBLE PRECISION A,SAVE IF(M)14,14,1 1 IF(N)14,14,2 2 IF(IROCO)3,4,3 3 MM=M MMM=-1 L=M LL=N GO TO 5 4 MM=1 MMM=M L=N LL=M 5 IA=1 ID=1 IF(INV)6,7,6 6 IA=LL ID=-1 7 DO 12 I=1,LL K=ITRA(IA) IF(K-IA)8,12,9 8 IF(K)13,13,10 9 IF(LL-K)13,10,10 10 IL=IA*MM K=K*MM DO 11 J=1,L SAVE=A(IL) A(IL)=A(K) A(K)=SAVE K=K+MMM 11 IL=IL+MMM 12 IA=IA+ID IER=0 RETURN 13 IER=1 RETURN 14 IER=-1 RETURN END SUBROUTINE DMFSD(A,N,EPS,IER) DIMENSION A(1) DOUBLE PRECISION DPIV,DSUM,A IF(N-1) 12,1,1 1 IER=0 KPIV=0 DO 11 K=1,N KPIV=KPIV+K IND=KPIV LEND=K-1 TOL=ABS(EPS*SNGL(A(KPIV))) DO 11 I=K,N DSUM=0.D0 IF(LEND) 2,4,2 2 DO 3 L=1,LEND LANF=KPIV-L LIND=IND-L 3 DSUM=DSUM+A(LANF)*A(LIND) 4 DSUM=A(IND)-DSUM IF(I-K) 10,5,10 5 IF(SNGL(DSUM)-TOL) 6,6,9 6 IF(DSUM) 12,12,7 7 IF(IER) 8,8,9 8 IER=K-1 9 DPIV=DSQRT(DSUM) A(KPIV)=DPIV DPIV=1.D0/DPIV GO TO 11 10 A(IND)=DSUM*DPIV 11 IND=IND+I RETURN 12 IER=-1 RETURN END SUBROUTINE DMFSS(A,N,EPS,IRANK,TRAC) DIMENSION A(1),TRAC(1) DOUBLE PRECISION SUM,A,TRAC,PIV,HOLD IF(N)36,36,1 1 IRANK=0 ISUB=0 KPIV=0 J=0 PIV=0.D0 DO 3 K=1,N J=J+K TRAC(K)=A(J) IF(A(J)-PIV)3,3,2 2 PIV=A(J) KSUB=J KPIV=K 3 CONTINUE DO 32 I=1,N ISUB=ISUB+I IM1=I-1 4 KMI=KPIV-I IF(KMI)35,9,5 5 JI=KSUB-KMI IDC=JI-ISUB JJ=ISUB-IM1 DO 6 K=JJ,ISUB KK=K+IDC HOLD=A(K) A(K)=A(KK) 6 A(KK)=HOLD KK=KSUB DO 7 K=KPIV,N II=KK-KMI HOLD=A(KK) A(KK)=A(II) A(II)=HOLD 7 KK=KK+K JJ=KPIV-1 II=ISUB DO 8 K=I,JJ HOLD=A(II) A(II)=A(JI) A(JI)=HOLD II=II+K 8 JI=JI+1 9 IF(IRANK)22,10,10 10 TRAC(KPIV)=TRAC(I) TRAC(I)=KPIV KK=IM1-IRANK KMI=ISUB-KK PIV=0.D0 IDC=IRANK+1 JI=ISUB-1 JK=KMI JJ=ISUB-I DO 19 K=I,N SUM=0.D0 IF(KK)13,13,11 11 DO 12 J=KMI,JI SUM=SUM-A(J)*A(JK) 12 JK=JK+1 13 JJ=JJ+K IF(K-I)14,14,16 14 SUM=A(ISUB)+SUM IF(SUM-DABS(A(ISUB)*DBLE(EPS)))20,20,15 15 A(ISUB)=DSQRT(SUM) KPIV=I+1 GOTO 19 16 SUM=(A(JK)+SUM)/A(ISUB) A(JK)=SUM IF(A(JJ))19,19,17 17 TRAC(K)=TRAC(K)-SUM*SUM HOLD=TRAC(K)/A(JJ) IF(PIV-HOLD)18,19,19 18 PIV=HOLD KPIV=K KSUB=JJ 19 JK=JJ+IDC GOTO 32 20 IF(IRANK)21,21,37 21 IRANK=-1 GOTO 4 22 IRANK=IM1 II=ISUB-IRANK JI=II DO 26 K=1,IRANK JI=JI-1 JK=ISUB-1 JJ=K-1 DO 26 J=I,N IDC=IRANK SUM=0.D0 KMI=JI KK=JK IF(JJ)25,25,23 23 DO 24 L=1,JJ IDC=IDC-1 SUM=SUM-A(KMI)*A(KK) KMI=KMI-IDC 24 KK=KK-1 25 A(KK)=(SUM+A(KK))/A(KMI) 26 JK=JK+J JJ=ISUB-I PIV=0.D0 KK=ISUB-1 DO 31 K=I,N JJ=JJ+K IDC=0 DO 28 J=K,N SUM=0.D0 KMI=JJ+IDC DO 27 L=II,KK JK=L+IDC 27 SUM=SUM+A(L)*A(JK) A(KMI)=SUM 28 IDC=IDC+J A(JJ)=A(JJ)+1.D0 TRAC(K)=A(JJ) IF(PIV-A(JJ))29,30,30 29 KPIV=K KSUB=JJ PIV=A(JJ) 30 II=II+K KK=KK+K 31 CONTINUE GOTO 4 32 CONTINUE 33 IF(IRANK)35,34,35 34 IRANK=N 35 RETURN 36 IRANK=-1 RETURN 37 IRANK=-2 RETURN END SUBROUTINE DMTDS(A,M,N,T,IOP,IER) DIMENSION A(1),T(1) DOUBLE PRECISION DSUM,A,T IF(M)2,2,1 1 IF(N)2,2,4 2 IER=-1 RETURN 3 IER=1 RETURN 4 MN=M*N MM=M*(M+1)/2 MM1=M-1 IER=0 ICS=M IRS=1 IMEND=M IF(IOP)5,2,6 5 MM=N*(N+1)/2 MM1=N-1 IRS=M ICS=1 IMEND=MN-M+1 MN=M 6 IOPE=MOD(IOP+3,3) IF(IABS(IOP)-3)7,7,2 7 IF(IOPE-1)8,18,8 8 MEND=1 LLD=IRS MSTA=1 MDEL=1 MX=1 LD=1 LX=0 9 IF(T(MSTA))10,3,10 10 DO 11 I=MEND,MN,ICS 11 A(I)=A(I)/T(MSTA) IF(MM1)2,15,12 12 DO 14 J=1,MM1 MSTA=MSTA+MDEL MDEL=MDEL+MX DO 14 I=MEND,MN,ICS DSUM=0.D0 L=MSTA LDX=LD LL=I DO 13 K=1,J DSUM=DSUM-T(L)*A(LL) LL=LL+LLD L=L+LDX 13 LDX=LDX+LX IF(T(L))14,3,14 14 A(LL)=(DSUM+A(LL))/T(L) 15 IF(IER)16,17,16 16 IER=0 RETURN 17 IF(IOPE)18,18,16 18 IER=1 MEND=IMEND MN=M*N LLD=-IRS MSTA=MM MDEL=-1 MX=0 LD=-MM1 LX=1 GOTO 9 END SUBROUTINE DCNP(Y,X,N) DIMENSION Y(1) DOUBLE PRECISION Y,X,F Y(1)=1.D0 IF(N)1,1,2 1 RETURN 2 Y(2)=X IF(N-1)1,1,3 3 F=X+X DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END SUBROUTINE DCNPS(Y,X,C,N) DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG IF(N)1,1,2 1 RETURN 2 IF(N-2)3,4,4 3 Y=C(1) RETURN 4 ARG=X+X H1=0.D0 H0=0.D0 DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5D0*(C(1)-H2+H0) RETURN END SUBROUTINE DPECN(P,N,BOUND,EPS,TOL,WORK) DIMENSION P(1),WORK(1) DOUBLE PRECISION P,WORK FL=BOUND*BOUND 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(SNGL(P(1))) 5 RETURN 6 NEND=N-2 WORK(N)=-P(N) DO 7 J=1,NEND,2 K=N-J FN=(NEND-1+K)*(NEND+3-K) FK=K*(K-1) 7 WORK(K-1)=-WORK(K+1)*DBLE(FK*FL/FN) IF(K-2)8,8,9 8 FN=DABS(WORK(1)) GOTO 10 9 FN=N-1 FN=ABS(SNGL(WORK(2))/FN) 10 IF(EPS+FN-TOL)11,11,5 11 EPS=EPS+FN N=N-1 DO 12 J=K,N,2 12 P(J-1)=P(J-1)+WORK(J-1) GOTO 1 END SUBROUTINE DPECS(P,N,BOUND,EPS,TOL,WORK) DIMENSION P(1),WORK(1) DOUBLE PRECISION P,WORK FL=BOUND*0.5 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(SNGL(P(1)))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(SNGL(P(1))) 5 RETURN 6 NEND=N-1 WORK(N)=-P(N) DO 7 J=1,NEND K=N-J FN=(NEND-1+K)*(N-K) FK=K*(K+K-1) 7 WORK(K)=-WORK(K+1)*DBLE(FK)*DBLE(FL)/DBLE(FN) FN=DABS(WORK(1)) IF(EPS+FN-TOL)8,8,5 8 EPS=EPS+FN N=NEND DO 9 J=1,NEND 9 P(J)=P(J)+WORK(J) GOTO 1 END SUBROUTINE DPQFB(C,IC,Q,LIM,IER) DIMENSION C(1),Q(1) DOUBLE PRECISION A,B,AA,BB,CA,CB,CC,CD,A1,B1,C1,H,HH,Q1,Q2,QQ1, 1 QQ2,QQQ1,QQQ2,DQ1,DQ2,EPS,EPS1,C,Q IER=0 J=IC+1 1 J=J-1 IF(J-1)40,40,2 2 IF(C(J))3,1,3 3 A=C(J) IF(A-1.D0)4,6,4 4 DO 5 I=1,J C(I)=C(I)/A CALL OVERFL(N) IF(N-2)40,5,5 5 CONTINUE 6 IF(J-3)41,38,7 7 EPS=1.D-14 EPS1=1.D-6 L=0 LL=0 Q1=Q(1) Q2=Q(2) QQ1=0.D0 QQ2=0.D0 AA=C(1) BB=C(2) CB=DABS(AA) CA=DABS(BB) IF(CB-CA)8,9,10 8 CC=CB+CB CB=CB/CA CA=1.D0 GO TO 11 9 CC=CA+CA CA=1.D0 CB=1.D0 GO TO 11 10 CC=CA+CA CA=CA/CB CB=1.D0 11 CD=CC*.1D0 12 A=0.D0 B=A A1=A B1=A I=J QQQ1=Q1 QQQ2=Q2 DQ1=HH DQ2=H 13 H=-Q1*B-Q2*A+C(I) CALL OVERFL(N) IF(N-2)42,14,14 14 B=A A=H I=I-1 IF(I-1)18,15,16 15 H=0.D0 16 H=-Q1*B1-Q2*A1+H CALL OVERFL(N) IF(N-2)42,17,17 17 C1=B1 B1=A1 A1=H GO TO 13 18 H=CA*DABS(A)+CB*DABS(B) IF(LL)19,19,39 19 L=L+1 IF(DABS(A)-EPS*DABS(C(1)))20,20,21 20 IF(DABS(B)-EPS*DABS(C(2)))39,39,21 21 IF(H-CC)22,22,23 22 AA=A BB=B CC=H QQ1=Q1 QQ2=Q2 23 IF(L-LIM)28,28,24 24 IF(H-CD)43,43,25 25 IF(Q(1))27,26,27 26 IF(Q(2))27,42,27 27 Q(1)=0.D0 Q(2)=0.D0 GO TO 7 28 HH=DMAX1(DABS(A1),DABS(B1),DABS(C1)) IF(HH)42,42,29 29 A1=A1/HH B1=B1/HH C1=C1/HH H=A1*C1-B1*B1 IF(H)30,42,30 30 A=A/HH B=B/HH HH=(B*A1-A*B1)/H H=(A*C1-B*B1)/H Q1=Q1+HH Q2=Q2+H IF(DABS(HH)-EPS*DABS(Q1))31,31,33 31 IF(DABS(H)-EPS*DABS(Q2))32,32,33 32 LL=1 GO TO 12 33 IF(L-1)12,12,34 34 IF(DABS(HH)-EPS1*DABS(Q1))35,35,12 35 IF(DABS(H)-EPS1*DABS(Q2))36,36,12 36 IF(DABS(QQQ1*HH)-DABS(Q1*DQ1))37,44,44 37 IF(DABS(QQQ2*H)-DABS(Q2*DQ2))12,44,44 38 Q(1)=C(1) Q(2)=C(2) Q(3)=0.D0 Q(4)=0.D0 RETURN 39 Q(1)=Q1 Q(2)=Q2 Q(3)=A Q(4)=B RETURN 40 IER=-1 RETURN 41 IER=-2 RETURN 42 IER=-3 GO TO 44 43 IER=1 44 Q(1)=QQ1 Q(2)=QQ2 Q(3)=AA Q(4)=BB RETURN END SUBROUTINE DPRBM(C,IC,RR,RC,POL,IR,IER) DIMENSION C(1),RR(1),RC(1),POL(1),Q(4) DOUBLE PRECISION C,RR,RC,POL,Q,EPS,A,B,H,Q1,Q2 EPS=1.D-6 LIM=100 IR=IC+1 1 IR=IR-1 IF(IR-1)42,42,2 2 IF(C(IR))3,1,3 3 IER=0 J=IR L=0 A=C(IR) DO 8 I=1,IR IF(L)4,4,7 4 IF(C(I))6,5,6 5 RR(I)=0.D0 RC(I)=0.D0 POL(J)=0.D0 J=J-1 GO TO 8 6 L=1 IST=I J=0 7 J=J+1 C(I)=C(I)/A POL(J)=C(I) CALL OVERFL(N) IF(N-2)42,8,8 8 CONTINUE Q1=0.D0 Q2=0.D0 9 IF(J-2)33,10,14 10 A=POL(1) RR(IST)=-A RC(IST)=0.D0 IR=IR-1 Q2=0.D0 IF(IR-1)13,13,11 11 DO 12 I=2,IR Q1=Q2 Q2=POL(I+1) 12 POL(I)=A*Q2+Q1 13 POL(IR+1)=A+Q2 GO TO 34 14 DO 22 L=1,10 N=1 15 Q(1)=Q1 Q(2)=Q2 CALL DPQFB(POL,J,Q,LIM,I) IF(I)16,24,23 16 IF(Q1)18,17,18 17 IF(Q2)18,21,18 18 GO TO (19,20,19,21),N 19 Q1=-Q1 N=N+1 GO TO 15 20 Q2=-Q2 N=N+1 GO TO 15 21 Q1=1.D0+Q1 22 Q2=1.D0-Q2 IER=3 IR=IR-J RETURN 23 IER=1 24 Q1=Q(1) Q2=Q(2) B=0.D0 A=0.D0 I=J 25 H=-Q1*B-Q2*A+POL(I) POL(I)=B B=A A=H I=I-1 IF(I-2)26,26,25 26 POL(2)=B POL(1)=A L=IR-1 IF(J-L)27,27,29 27 DO 28 I=J,L 28 POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1 29 POL(L)=POL(L)+POL(L+1)*Q2+Q1 POL(IR)=POL(IR)+Q2 H=-.5D0*Q2 A=H*H-Q1 B=DSQRT(DABS(A)) IF(A)30,30,31 30 RR(IST)=H RC(IST)=B IST=IST+1 RR(IST)=H RC(IST)=-B GO TO 32 31 B=H+DSIGN(B,H) RR(IST)=Q1/B RC(IST)=0.D0 IST=IST+1 RR(IST)=B RC(IST)=0.D0 32 IST=IST+1 J=J-2 GO TO 9 33 IR=IR-1 34 A=0.D0 DO 38 I=1,IR Q1=C(I) Q2=POL(I+1) POL(I)=Q2 IF(Q1)35,36,35 35 Q2=(Q1-Q2)/Q1 36 Q2=DABS(Q2) IF(Q2-A)38,38,37 37 A=Q2 38 CONTINUE I=IR+1 POL(I)=1.D0 RR(I)=A RC(I)=0.D0 IF(IER)39,39,41 39 IF(A-EPS)41,41,40 40 IER=-1 41 RETURN 42 IER=2 IR=0 RETURN END SUBROUTINE DPRQD(C,IC,Q,E,POL,IR,IER) DIMENSION E(1),Q(1),C(1),POL(1) DOUBLE PRECISION Q,E,O,P,T,EXPT,ESAV,U,V,W,C,POL,EPS IR=IC IER=0 EPS=1.D-16 TOL=1.E-6 LIMIT=10*IC KOUNT=0 1 IF(IR-1)79,79,2 2 IF(C(IR))4,3,4 3 IR=IR-1 GOTO 1 4 O=1.0D0/C(IR) IEND=IR-1 ISTA=1 NSAV=IR+1 JBEG=1 DO 9 I=1,IR J=NSAV-I IF(C(I))7,5,7 5 GOTO(6,8),JBEG 6 NSAV=NSAV+1 Q(ISTA)=0.D0 E(ISTA)=0.D0 ISTA=ISTA+1 GOTO 9 7 JBEG=2 8 Q(J)=C(I)*O C(I)=Q(J) 9 CONTINUE ESAV=0.D0 Q(ISTA)=0.D0 10 NSAV=IR EXPT=IR-ISTA E(ISTA)=EXPT DO 11 I=ISTA,IEND EXPT=EXPT-1.0D0 POL(I+1)=EPS*DABS(Q(I+1))+EPS 11 E(I+1)=Q(I+1)*EXPT IF(ISTA-IEND)12,20,60 12 JEND=IEND-1 DO 19 I=ISTA,JEND IF(I-ISTA)13,16,13 13 IF(DABS(E(I))-POL(I+1))14,14,16 14 NSAV=I DO 15 K=I,JEND IF(DABS(E(K))-POL(K+1))15,15,80 15 CONTINUE GOTO 21 16 DO 19 K=I,IEND E(K+1)=E(K+1)/E(I) Q(K+1)=E(K+1)-Q(K+1) IF(K-I)18,17,18 17 IF(DABS(Q(I+1))-POL(I+1))80,80,19 18 Q(K+1)=Q(K+1)/Q(I+1) POL(K+1)=POL(K+1)/DABS(Q(I+1)) E(K)=Q(K+1)-E(K) 19 CONTINUE 20 Q(IR)=-Q(IR) 21 E(ISTA)=0.D0 NRAN=NSAV-1 22 E(NRAN+1)=0.D0 IF(NRAN-ISTA)24,23,31 23 Q(ISTA+1)=Q(ISTA+1)+EXPT E(ISTA+1)=0.D0 24 E(ISTA)=ESAV IF(IR-NSAV)60,60,25 25 ISTA=NSAV ESAV=E(ISTA) GOTO 10 26 P=P+EXPT IF(O)27,28,28 27 Q(NRAN)=P Q(NRAN+1)=P E(NRAN)=T E(NRAN+1)=-T GOTO 29 28 Q(NRAN)=P-T Q(NRAN+1)=P+T E(NRAN)=0.D0 29 NRAN=NRAN-2 GOTO 22 30 Q(NRAN+1)=EXPT+P NRAN=NRAN-1 GOTO 22 31 JBEG=ISTA+1 JEND=NRAN-1 TEPS=EPS TDELT=1.E-2 32 KOUNT=KOUNT+1 P=Q(NRAN+1) R=ABS(SNGL(E(NRAN))) IF(R-TEPS)30,30,33 33 S=ABS(SNGL(E(JEND))) IF(S-R)38,38,34 34 IF(R-TDELT)36,35,35 35 P=0.D0 36 O=P DO 37 J=JBEG,NRAN Q(J)=Q(J)+E(J)-E(J-1)-O IF(DABS(Q(J))-POL(J))81,81,37 37 E(J)=Q(J+1)*E(J)/Q(J) Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O GOTO 54 38 P=0.5D0*(Q(NRAN)+E(NRAN)+Q(NRAN+1)) O=P*P-Q(NRAN)*Q(NRAN+1) T=DSQRT(DABS(O)) IF(S-TEPS)26,26,39 39 IF(O)43,40,40 40 IF(P)42,41,41 41 T=-T 42 P=P+T R=S GOTO 34 43 IF(S-TDELT)44,35,35 44 O=Q(JBEG)+E(JBEG)-P IF(DABS(O)-POL(JBEG))81,81,45 45 T=(T/O)**2 U=E(JBEG)*Q(JBEG+1)/(O*(1.0D0+T)) V=O+U KOUNT=KOUNT+2 DO 53 J=JBEG,NRAN O=Q(J+1)+E(J+1)-U-P IF(DABS(V)-POL(J))46,46,49 46 IF(J-NRAN)81,47,81 47 EXPT=EXPT+P IF(ABS(SNGL(E(JEND)))-TOL)48,48,81 48 P=0.5D0*(V+O-E(JEND)) O=P*P-(V-U)*(O-U*T-O*W*(1.D0+T)/Q(JEND)) T=DSQRT(DABS(O)) GOTO 26 49 IF(DABS(O)-POL(J+1))46,46,50 50 W=U*O/V T=T*(V/O)**2 Q(J)=V+W-E(J-1) U=0.D0 IF(J-NRAN)51,52,52 51 U=Q(J+2)*E(J+1)/(O*(1.D0+T)) 52 V=O+U-W IF(DABS(Q(J))-POL(J))81,81,53 53 E(J)=W*V*(1.0D0+T)/Q(J) Q(NRAN+1)=V-E(NRAN) 54 EXPT=EXPT+P TEPS=TEPS*1.1 TDELT=TDELT*1.1 IF(KOUNT-LIMIT)32,55,55 55 IER=1 56 IEND=NSAV-NRAN-1 E(ISTA)=ESAV IF(IEND)59,59,57 57 DO 58 I=1,IEND J=ISTA+I K=NRAN+1+I E(J)=E(K) 58 Q(J)=Q(K) 59 IR=ISTA+IEND 60 IR=IR-1 IF(IR)78,78,61 61 DO 62 I=1,IR Q(I)=Q(I+1) 62 E(I)=E(I+1) POL(IR+1)=1.D0 IEND=IR-1 JBEG=1 DO 69 J=1,IR ISTA=IR+1-J O=0.D0 P=Q(ISTA) T=E(ISTA) IF(T)65,63,65 63 DO 64 I=ISTA,IR POL(I)=O-P*POL(I+1) 64 O=POL(I+1) GOTO 69 65 GOTO(66,67),JBEG 66 JBEG=2 POL(ISTA)=0.D0 GOTO 69 67 JBEG=1 U=P*P+T*T P=P+P DO 68 I=ISTA,IEND POL(I)=O-P*POL(I+1)+U*POL(I+2) 68 O=POL(I+1) POL(IR)=O-P 69 CONTINUE IF(IER)78,70,78 70 P=0.D0 DO 75 I=1,IR IF(C(I))72,71,72 71 O=DABS(POL(I)) GOTO 73 72 O=DABS((POL(I)-C(I))/C(I)) 73 IF(P-O)74,75,75 74 P=O 75 CONTINUE IF(SNGL(P)-TOL)77,76,76 76 IER=-1 77 Q(IR+1)=P E(IR+1)=0.D0 78 RETURN 79 IER=2 IR=0 RETURN 80 IER=4 IR=ISTA GOTO 60 81 IER=3 GOTO 56 END SUBROUTINE DQATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX) DIMENSION AUX(1) DOUBLE PRECISION AUX,XL,XU,X,Y,H,HH,HD,P,Q,SM,FCT AUX(1)=.5D0*(FCT(XL)+FCT(XU)) H=XU-XL IF(NDIM-1)8,8,1 1 IF(H)2,10,2 2 HH=H E=EPS/DABS(H) DELT2=0. P=1.D0 JJ=1 DO 7 I=2,NDIM Y=AUX(1) DELT1=DELT2 HD=HH HH=.5D0*HH P=.5D0*P X=XL+HH SM=0.D0 DO 3 J=1,JJ SM=SM+FCT(X) 3 X=X+HD AUX(I)=.5D0*AUX(I-1)+P*SM Q=1.D0 JI=I-1 DO 4 J=1,JI II=I-J Q=Q+Q Q=Q+Q 4 AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.D0) DELT2=DABS(Y-AUX(1)) IF(I-5)7,5,5 5 IF(DELT2-E)10,10,6 6 IF(DELT2-DELT1)7,11,11 7 JJ=JJ+JJ 8 IER=2 9 Y=H*AUX(1) RETURN 10 IER=0 GO TO 9 11 IER=1 Y=H*Y RETURN END SUBROUTINE DQA4(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.8588635689012034D1 Y=.39920814442273524D-3*FCT(X) X=.39269635013582872D1 Y=Y+.34155966014826951D-1*FCT(X) X=.13390972881263614D1 Y=Y+.41560465162978376D0*FCT(X) X=.14530352150331709D0 Y=Y+.13222940251164826D1*FCT(X) RETURN END SUBROUTINE DQA8(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.21984272840962651D2 Y=.53096149480223645D-9*FCT(X) X=.14972627088426393D2 Y=Y+.46419616897304213D-6*FCT(X) X=.10093323675221343D2 Y=Y+.54237201850757630D-4*FCT(X) X=.64831454286271704D1 Y=Y+.18645680172483611D-2*FCT(X) X=.38094763614849071D1 Y=Y+.25760623071019947D-1*FCT(X) X=.19051136350314284D1 Y=Y+.16762008279797166D0*FCT(X) X=.67724908764928915D0 Y=Y+.56129491705706735D0*FCT(X) X=.7479188259681827D-1 Y=Y+.10158589580332275D1*FCT(X) RETURN END SUBROUTINE DQG4(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.43056815579702629D0*B Y=.17392742256872693D0*(FCT(A+C)+FCT(A-C)) C=.16999052179242813D0*B Y=B*(Y+.32607257743127307D0*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DQG8(XL,XU,FCT,Y) DOUBLE PRECISION XL,XU,Y,A,B,C,FCT A=.5D0*(XU+XL) B=XU-XL C=.48014492824876812D0*B Y=.50614268145188130D-1*(FCT(A+C)+FCT(A-C)) C=.39833323870681337D0*B Y=Y+.11119051722668724D0*(FCT(A+C)+FCT(A-C)) C=.26276620495816449D0*B Y=Y+.15685332293894364D0*(FCT(A+C)+FCT(A-C)) C=.9171732124782490D-1*B Y=B*(Y+.18134189168918099D0*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE DQHFE(H,Y,DERY,Z,NDIM) DIMENSION Y(1),DERY(1),Z(1) DOUBLE PRECISION Y,DERY,Z,H,HH,HS,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H HS=.16666666666666667D0*H DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DQHFG(X,Y,DERY,Z,NDIM) DIMENSION X(1),Y(1),DERY(1),Z(1) DOUBLE PRECISION X,Y,DERY,Z,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5D0*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.33333333333333333D0*SUM2* 1(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DQHSE(H,Y,FDY,SDY,Z,NDIM) DIMENSION Y(1),FDY(1),SDY(1),Z(1) DOUBLE PRECISION Y,FDY,SDY,Z,H,HH,HF,HT,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H HF=.2D0*H HT=.08333333333333333D0*H DO 2 I=2,NDIM SUM1=SUM2 0SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+ 1 HT*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DQH8(FCT,Y) DOUBLE PRECISION X,Y,Z,FCT X=.29306374202572440D1 Z=-X Y=.19960407221136762D-3*(FCT(X)+FCT(Z)) X=.19816567566958429D1 Z=-X Y=Y+.17077983007413475D-1*(FCT(X)+FCT(Z)) X=.11571937124467802D1 Z=-X Y=Y+.20780232581489188D0*(FCT(X)+FCT(Z)) X=.38118699020732212D0 Z=-X Y=Y+.66114701255824129D0*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE DQL4(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.9395070912301133D1 Y=.53929470556132745D-3*FCT(X) X=.45366202969211280D1 Y=Y+.38887908515005384D-1*FCT(X) X=.17457611011583466D1 Y=Y+.35741869243779969D0*FCT(X) X=.32254768961939231D0 Y=Y+.60315410434163360D0*FCT(X) RETURN END SUBROUTINE DQL8(FCT,Y) DOUBLE PRECISION X,Y,FCT X=.22863131736889264D2 Y=.10480011748715104D-8*FCT(X) X=.15740678641278005D2 Y=Y+.8485746716272532D-6*FCT(X) X=.10758516010180995D2 Y=Y+.9076508773358213D-4*FCT(X) X=.70459054023934657D1 Y=Y+.27945362352256725D-2*FCT(X) X=.42667001702876588D1 Y=Y+.33343492261215652D-1*FCT(X) X=.22510866298661307D1 Y=Y+.17579498663717181D0*FCT(X) X=.9037017767993799D0 Y=Y+.41878678081434296D0*FCT(X) X=.17027963230510100D0 Y=Y+.36918858934163753D0*FCT(X) RETURN END SUBROUTINE DQSF(H,Y,Z,NDIM) DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,H,HT,SUM1,SUM2,AUX,AUX1,AUX2 HT=.33333333333333333D0*H IF(NDIM-5)7,8,1 1 SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(3)+AUX1+Y(5)) AUX2=HT*(Y(1)+3.875D0*(Y(2)+Y(5))+2.625D0*(Y(3)+Y(4))+Y(6)) SUM2=Y(5)+Y(5) SUM2=SUM2+SUM2 SUM2=AUX2-HT*(Y(4)+SUM2+Y(6)) Z(1)=0.D0 AUX=Y(3)+Y(3) AUX=AUX+AUX Z(2)=SUM2-HT*(Y(2)+AUX+Y(4)) Z(3)=SUM1 Z(4)=SUM2 IF(NDIM-6)5,5,2 2 DO 4 I=7,NDIM,2 SUM1=AUX1 SUM2=AUX2 AUX1=Y(I-1)+Y(I-1) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I)) Z(I-2)=SUM1 IF(I-NDIM)3,6,6 3 AUX2=Y(I)+Y(I) AUX2=AUX2+AUX2 AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1)) 4 Z(I-1)=SUM2 5 Z(NDIM-1)=AUX1 Z(NDIM)=AUX2 RETURN 6 Z(NDIM-1)=SUM2 Z(NDIM)=AUX1 RETURN 7 IF(NDIM-3)12,11,8 8 SUM2=1.125D0*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4)) SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) Z(1)=0.D0 AUX1=Y(3)+Y(3) AUX1=AUX1+AUX1 Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4)) IF(NDIM-5)10,9,9 9 AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5)) 10 Z(3)=SUM1 Z(4)=SUM2 RETURN 11 SUM1=HT*(1.25D0*Y(1)+Y(2)+Y(2)-.25D0*Y(3)) SUM2=Y(2)+Y(2) SUM2=SUM2+SUM2 Z(3)=HT*(Y(1)+SUM2+Y(3)) Z(1)=0.D0 Z(2)=SUM1 12 RETURN END SUBROUTINE DRHARM(A,M,INV,S,IFERR) DIMENSION A(1),L(3),INV(1),S(1) DOUBLE PRECISION A,SI,AP1IM,FN,CO,CIRE,AP2IM,S,SS,DEL,CIIM,AP1RE, 1 CNIRE,SC,SIS,AP2RE,CNIIM IFSET=1 L(1)=M L(2)=0 L(3)=0 NTOT=2**M NTOT2 = 2*NTOT FN = NTOT DO 3 I = 2,NTOT2,2 3 A(I) = -A(I) DO 6 I = 1,NTOT2 6 A(I) = A(I)/FN CALL DHARM(A,L,INV,S,IFSET,IFERR) 21 DO 52 I=1,NTOT,2 J0=NTOT2+2-I A(J0)=A(J0-2) 52 A(J0+1)=A(J0-1) A(NTOT2+3)=A(1) A(NTOT2+4)=A(2) K0=NTOT+1 DO 104 I=1,K0,2 K1=NTOT2-I+4 AP1RE=.5*(A(I)+A(K1)) AP2RE=-.5*(A(I+1)+A(K1+1)) AP1IM=.5*(-A(I+1)+A(K1+1)) AP2IM=-.5*(A(I)-A(K1)) A(I)=AP1RE A(I+1)=AP1IM A(K1)=AP2RE 104 A(K1+1)=AP2IM NTO = NTOT/2 110 NT=NTO+1 DEL=3.141592653589793/DFLOAT(NTOT) SS=DSIN(DEL) SC=DCOS(DEL) SI=0.0 CO=1.0 114 DO 116 I=1,NT K6=NTOT2-2*I+5 AP2RE=A(K6)*CO+A(K6+1)*SI AP2IM=-A(K6)*SI+A(K6+1)*CO CIRE=.5*(A(2*I-1)+AP2RE) CIIM=.5*(A(2*I)+AP2IM) CNIRE=.5*(A(2*I-1)-AP2RE) CNIIM=.5*(A(2*I)-AP2IM) A(2*I-1)=CIRE A(2*I)=CIIM A(K6)=CNIRE A(K6+1)=-CNIIM SIS=SI SI=SI*SC+CO*SS 116 CO=CO*SC-SIS*SS DO 117 I=1,NTOT,2 K8=NTOT+4+I A(K8-2)=A(K8) 117 A(K8-1)=A(K8+1) DO 500 I=3,NTOT2,2 A(I) = 2. * A(I) 500 A(I + 1) = -2. * A(I + 1) RETURN END SUBROUTINE DRKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) DIMENSION Y(1),DERY(1),AUX(8,1),A(4),B(4),C(4),PRMT(1) DOUBLE PRECISION PRMT,Y,DERY,AUX,A,B,C,X,XEND,H,AJ,BJ,CJ,R1,R2, 1DELT DO 1 I=1,NDIM 1 AUX(8,I)=.066666666666666667D0*DERY(I) X=PRMT(1) XEND=PRMT(2) H=PRMT(3) PRMT(5)=0.D0 CALL FCT(X,Y,DERY) IF(H*(XEND-X))38,37,2 2 A(1)=.5D0 A(2)=.29289321881345248D0 A(3)=1.7071067811865475D0 A(4)=.16666666666666667D0 B(1)=2.D0 B(2)=1.D0 B(3)=1.D0 B(4)=2.D0 C(1)=.5D0 C(2)=.29289321881345248D0 C(3)=1.7071067811865475D0 C(4)=.5D0 DO 3 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=0.D0 3 AUX(6,I)=0.D0 IREC=0 H=H+H IHLF=-1 ISTEP=0 IEND=0 4 IF((X+H-XEND)*H)7,6,5 5 H=XEND-X 6 IEND=1 7 CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT) IF(PRMT(5))40,8,40 8 ITEST=0 9 ISTEP=ISTEP+1 J=1 10 AJ=A(J) BJ=B(J) CJ=C(J) DO 11 I=1,NDIM R1=H*DERY(I) R2=AJ*(R1-BJ*AUX(6,I)) Y(I)=Y(I)+R2 R2=R2+R2+R2 11 AUX(6,I)=AUX(6,I)+R2-CJ*R1 IF(J-4)12,15,15 12 J=J+1 IF(J-3)13,14,13 13 X=X+.5D0*H 14 CALL FCT(X,Y,DERY) GOTO 10 15 IF(ITEST)16,16,20 16 DO 17 I=1,NDIM 17 AUX(4,I)=Y(I) ITEST=1 ISTEP=ISTEP+ISTEP-2 18 IHLF=IHLF+1 X=X-H H=.5D0*H DO 19 I=1,NDIM Y(I)=AUX(1,I) DERY(I)=AUX(2,I) 19 AUX(6,I)=AUX(3,I) GOTO 9 20 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)21,23,21 21 CALL FCT(X,Y,DERY) DO 22 I=1,NDIM AUX(5,I)=Y(I) 22 AUX(7,I)=DERY(I) GOTO 9 23 DELT=0.D0 DO 24 I=1,NDIM 24 DELT=DELT+AUX(8,I)*DABS(AUX(4,I)-Y(I)) IF(DELT-PRMT(4))28,28,25 25 IF(IHLF-10)26,36,36 26 DO 27 I=1,NDIM 27 AUX(4,I)=AUX(5,I) ISTEP=ISTEP+ISTEP-4 X=X-H IEND=0 GOTO 18 28 CALL FCT(X,Y,DERY) DO 29 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=AUX(6,I) Y(I)=AUX(5,I) 29 DERY(I)=AUX(7,I) CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))40,30,40 30 DO 31 I=1,NDIM Y(I)=AUX(1,I) 31 DERY(I)=AUX(2,I) IREC=IHLF IF(IEND)32,32,39 32 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H IF(IHLF)4,33,33 33 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)4,34,4 34 IF(DELT-.02D0*PRMT(4))35,35,4 35 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H GOTO 4 36 IHLF=11 CALL FCT(X,Y,DERY) GOTO 39 37 IHLF=12 GOTO 39 38 IHLF=13 39 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) 40 RETURN END SUBROUTINE DRTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER) DOUBLE PRECISION X,F,FCT,XLI,XRI,XL,XR,FL,FR,TOL,TOLF,A,DX,XM,FM IER=0 XL=XLI XR=XRI X=XL TOL=X F=FCT(TOL) IF(F)1,16,1 1 FL=F X=XR TOL=X F=FCT(TOL) IF(F)2,16,2 2 FR=F IF(DSIGN(1.D0,FL)+DSIGN(1.D0,FR))25,3,25 3 I=0 TOLF=100.*EPS 4 I=I+1 DO 13 K=1,IEND X=.5D0*(XL+XR) TOL=X F=FCT(TOL) IF(F)5,16,5 5 IF(DSIGN(1.D0,F)+DSIGN(1.D0,FR))7,6,7 6 TOL=XL XL=XR XR=TOL TOL=FL FL=FR FR=TOL 7 TOL=F-FL A=F*TOL A=A+A IF(A-FR*(FR-FL))8,9,9 8 IF(I-IEND)17,17,9 9 XR=X FR=F TOL=EPS A=DABS(XR) IF(A-1.D0)11,11,10 10 TOL=TOL*A 11 IF(DABS(XR-XL)-TOL)12,12,13 12 IF(DABS(FR-FL)-TOLF)14,14,13 13 CONTINUE IER=1 14 IF(DABS(FR)-DABS(FL))16,16,15 15 X=XL F=FL 16 RETURN 17 A=FR-F DX=(X-XL)*FL*(1.D0+F*(A-TOL)/(A*(FR-FL)))/TOL XM=X FM=F X=XL-DX TOL=X F=FCT(TOL) IF(F)18,16,18 18 TOL=EPS A=DABS(X) IF(A-1.D0)20,20,19 19 TOL=TOL*A 20 IF(DABS(DX)-TOL)21,21,22 21 IF(DABS(F)-TOLF)16,16,22 22 IF(DSIGN(1.D0,F)+DSIGN(1.D0,FL))24,23,24 23 XR=X FR=F GO TO 4 24 XL=X FL=F XR=XM FR=FM GO TO 4 25 IER=2 RETURN END SUBROUTINE DRTNI(X,F,DERF,FCT,XST,EPS,IEND,IER) DOUBLE PRECISION X,F,DERF,XST,TOL,TOLF,DX,A IER=0 X=XST TOL=X CALL FCT(TOL,F,DERF) TOLF=100.*EPS DO 6 I=1,IEND IF(F)1,7,1 1 IF(DERF)2,8,2 2 DX=F/DERF X=X-DX TOL=X CALL FCT(TOL,F,DERF) TOL=EPS A=DABS(X) IF(A-1.D0)4,4,3 3 TOL=TOL*A 4 IF(DABS(DX)-TOL)5,5,6 5 IF(DABS(F)-TOLF)7,7,6 6 CONTINUE IER=1 7 RETURN 8 IER=2 RETURN END SUBROUTINE DRTWI(X,VAL,FCT,XST,EPS,IEND,IER) DOUBLE PRECISION X,VAL,FCT,XST,A,B,D,TOL IER=0 TOL=XST X=FCT(TOL) A=X-XST B=-A TOL=X VAL=X-FCT(TOL) DO 6 I=1,IEND IF(VAL)1,7,1 1 B=B/VAL-1.D0 IF(B)2,8,2 2 A=A/B X=X+A B=VAL TOL=X VAL=X-FCT(TOL) TOL=EPS D=DABS(X) IF(D-1.D0)4,4,3 3 TOL=TOL*D 4 IF(DABS(A)-TOL)5,5,6 5 IF(DABS(VAL)-1.D1*TOL)7,7,6 6 CONTINUE IER=1 7 RETURN 8 IER=2 RETURN END SUBROUTINE DSE35(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,A,B,C,D IF(NDIM-5)4,1,1 1 B=Y(1) C=Y(2) DO 3 I=5,NDIM A=B B=C C=Y(I-2) D=C-B-Y(I-1) D=D+D+C D=D+D+A+Y(I) IF(I-5)2,2,3 2 Z(1)=A-.014285714285714286D0*D Z(2)=B+.057142857142857143D0*D 3 Z(I-2)=C-.08571428571428571D0*D Z(NDIM-1)=Y(NDIM-1)+.057142857142857143D0*D Z(NDIM)=Y(NDIM)-.014285714285714286D0*D IER=0 RETURN 4 IER=-1 RETURN END SUBROUTINE DSG13(X,Y,Z,NDIM,IER) DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,XM,YM,T1,T2,T3,H IF(NDIM-3)7,1,1 1 DO 6 I=3,NDIM XM=.33333333333333333D0*(X(I-2)+X(I-1)+X(I)) YM=.33333333333333333D0*(Y(I-2)+Y(I-1)+Y(I)) T1=X(I-2)-XM T2=X(I-1)-XM T3=X(I)-XM XM=T1*T1+T2*T2+T3*T3 IF(XM)3,3,2 2 XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM 3 IF(I-3)4,4,5 4 H=XM*T1+YM 5 Z(I-2)=H 6 H=XM*T2+YM Z(NDIM-1)=H Z(NDIM)=XM*T3+YM IER=0 RETURN 7 IER=-1 RETURN END SUBROUTINE DSINV(A,N,EPS,IER) DIMENSION A(1) DOUBLE PRECISION A,DIN,WORK CALL DMFSD(A,N,EPS,IER) IF(IER) 9,1,1 1 IPIV=N*(N+1)/2 IND=IPIV DO 6 I=1,N DIN=1.D0/A(IPIV) A(IPIV)=DIN MIN=N KEND=I-1 LANF=N-KEND IF(KEND) 5,5,2 2 J=IND DO 4 K=1,KEND WORK=0.D0 MIN=MIN-1 LHOR=IPIV LVER=J DO 3 L=LANF,MIN LVER=LVER+1 LHOR=LHOR+L 3 WORK=WORK+A(LVER)*A(LHOR) A(J)=-WORK*DIN 4 J=J-MIN 5 IPIV=IPIV-MIN 6 IND=IND-1 DO 8 I=1,N IPIV=IPIV+I J=IPIV DO 8 K=I,N WORK=0.D0 LHOR=J DO 7 L=K,N LVER=LHOR+K-I WORK=WORK+A(LHOR)*A(LVER) 7 LHOR=LHOR+L A(J)=WORK 8 J=J+K 9 RETURN END SUBROUTINE DCSP(Y,X,N) DIMENSION Y(1) DOUBLE PRECISION Y,X,F Y(1)=1.D0 IF(N)1,1,2 1 RETURN 2 Y(2)=X+X-1.D0 IF(N-1)1,1,3 3 F=Y(2)+Y(2) DO 4 I=2,N 4 Y(I+1)=F*Y(I)-Y(I-1) RETURN END SUBROUTINE DCSPS(Y,X,C,N) DIMENSION C(1) DOUBLE PRECISION C,Y,X,H0,H1,H2,ARG IF(N)1,1,2 1 RETURN 2 IF(N-2)3,4,4 3 Y=C(1) RETURN 4 ARG=X+X-1.D0 ARG=ARG+ARG H1=0.D0 H0=0.D0 DO 5 I=1,N K=N-I H2=H1 H1=H0 5 H0=ARG*H1-H2+C(K+1) Y=0.5D0*(C(1)-H2+H0) RETURN END SUBROUTINE DTCNP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0 IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+C(2)*B POL(2)=C(2)*A IF(N-2)2,2,4 4 WORK(1)=1.D0 WORK(2)=B WORK(3)=0.D0 WORK(4)=A XD=A+A X0=B+B DO 6 J=3,N P=0.D0 DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0.D0 WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END SUBROUTINE DTCSP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,XD,X0 IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 XD=A+A X0=B+B-1.D0 POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 4 WORK(1)=1.D0 WORK(2)=X0 WORK(3)=0.D0 WORK(4)=XD XD=XD+XD X0=X0+X0 DO 6 J=3,N P=0.D0 DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0.D0 WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END SUBROUTINE DTEAS(X,N,FIN,EPS,IER) DIMENSION X(1) DOUBLE PRECISION X,FIN,W1,W2,W3,W4,W5,W6,W7,T NEW=N IF(NEW-10)1,2,2 1 IER=-1 RETURN 2 ISW1=0 ISW2=0 W1=1.D38 W7=X(4)-X(3) IF(W7)3,4,3 3 W1=1.D0/W7 4 W5=1.D38 W7=X(2)-X(1) IF(W7)5,6,5 5 W5=1.D0/W7 6 W4=X(3)-X(2) IF(W4)9,7,9 7 W4=1.D38 T=X(2) W2=X(3) 8 W3=1.D38 GO TO 17 9 W4=1.D0/W4 T=1.D38 W7=W4-W5 IF(W7)10,11,10 10 T=X(2)+1.D0/W7 11 W2=W1-W4 IF(W2)15,12,15 12 W2=1.D38 IF(T-1.D38)13,14,14 13 ISW2=1 14 W3=W4 GO TO 17 15 W2=X(3)+1.D0/W2 W7=W2-T IF(W7)16,8,16 16 W3=W4+1.D0/W7 17 ISW1=ISW2 ISW2=0 IMIN=4 DO 40 I=5,NEW IAUS=I-IMIN W4=1.D38 W5=X(I-1) W7=X(I)-X(I-1) IF(W7)18,24,18 18 W4=1.D0/W7 IF(W1-1.D38)19,25,25 19 W6=W4-W1 IF(DABS(W6)-DABS(W4)*1.D-12)20,20,22 20 ISW2=1 IF(W6)22,21,22 21 W5=1.D38 W6=W1 IF(W2-1.D38)28,26,26 22 W5=X(I-1)+1.D0/W6 IF(DABS(W5)-DABS(X(I-1))*1.D-10)23,24,24 23 IF(W5)36,24,36 24 W7=W5-W2 IF(W7)27,25,27 25 W6=1.D38 26 ISW2=0 X(IAUS)=W2 GO TO 37 27 W6=W1+1.D0/W7 28 IF(ISW1-1)33,29,29 29 IF(W2-1.D38)30,32,32 30 W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2) IF(1.D0+W7)31,38,31 31 X(IAUS)=W7*W2/(1.D0+W7) GO TO 39 32 X(IAUS)=W5+T-X(I-2) GO TO 39 33 W7=W6-W3 IF(W7)34,38,34 34 X(IAUS)=W2+1.D0/W7 IF(DABS(X(IAUS))-DABS(W2)*1.D-10)35,37,37 35 IF(X(IAUS))36,37,36 36 NEW=IAUS-1 ISW2=0 GO TO 41 37 IF(W2-1.D38)39,38,38 38 X(IAUS)=1.D38 IMIN=I 39 W1=W4 T=W2 W2=W5 W3=W6 ISW1=ISW2 40 ISW2=0 NEW=NEW-IMIN 41 IEND=NEW-1 DO 47 I=1,IEND HE1=DABS(X(I)-X(I+1)) HE2=DABS(X(I+1)) IF(HE1-EPS)44,44,42 42 IF(HE2-1.)46,46,43 43 IF(HE1-EPS*HE2)44,44,46 44 ISW2=ISW2+1 IF(3-ISW2)45,45,47 45 FIN=X(I) IER=0 RETURN 46 ISW2=0 47 CONTINUE IF(NEW-6)48,2,2 48 FIN=X(NEW) IER=1 RETURN END SUBROUTINE DTEUL (FCT,SUM,MAX,EPS,IER) DIMENSION Y(15) DOUBLE PRECISION FCT,SUM,Y,AMN,AMP IF(MAX)1,1,2 1 IER=-1 GOTO 12 2 IER=1 I=1 M=1 N=1 Y(1)=FCT(N) SUM=Y(1)*.5D0 3 J=0 4 I=I+1 IF(I-MAX)5,5,12 5 N=I AMN=FCT(N) DO 6 K=1,M AMP=(AMN+Y(K))*.5D0 Y(K)=AMN 6 AMN=AMP IF(DABS(AMN)-DABS(Y(M)))7,9,9 7 IF(M-15)8,9,9 8 M=M+1 Y(M)=AMN AMN=.5D0*AMN 9 SUM=SUM+AMN IF(ABS(SNGL(AMN))-EPS*ABS(SNGL(SUM)))10,10,3 10 J=J+1 IF(J-5)4,11,11 11 IER=0 12 RETURN END SUBROUTINE DQTFE(H,Y,Z,NDIM) DIMENSION Y(1),Z(1) DOUBLE PRECISION Y,Z,H,HH,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 HH=.5D0*H DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DQTFG(X,Y,Z,NDIM) DIMENSION X(1),Y(1),Z(1) DOUBLE PRECISION X,Y,Z,SUM1,SUM2 SUM2=0.D0 IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+.5D0*(X(I)-X(I-1))*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE DTHEP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,FI,XD,X0 IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 XD=A+A X0=B+B POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 4 WORK(1)=1.D0 WORK(2)=X0 WORK(3)=0.D0 WORK(4)=XD FI=2.D0 DO 6 J=3,N P=0.D0 DO 5 K=2,J H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=P*XD FI=FI+2.D0 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE DTLAP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,Q2,FI IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+C(2)-B*C(2) POL(2)=-C(2)*A IF(N-2)2,2,4 4 WORK(1)=1.D0 WORK(2)=1.D0-B WORK(3)=0.D0 WORK(4)=-A FI=1.D0 DO 6 J=3,N FI=FI+1.D0 Q=1.D0/FI Q1=Q-1.D0 Q2=1.D0-Q1-B*Q Q=Q*A P=0.D0 DO 5 K=2,J H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1 P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=-Q*P 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE DTLEP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) DOUBLE PRECISION A,B,POL,C,WORK,H,P,Q,Q1,FI IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+B*C(2) POL(2)=A*C(2) IF(N-2)2,2,4 4 WORK(1)=1.D0 WORK(2)=B WORK(3)=0.D0 WORK(4)=A FI=1.D0 DO 6 J=3,N FI=FI+1.D0 Q=1.D0/FI-1.D0 Q1=1.D0-Q P=0.D0 DO 5 K=2,J H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0.D0 WORK(2*J)=A*P*Q1 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE DATSE(X,ZS,DZ,F,IROW,ICOL,ARG,VAL,NDIM) DIMENSION F(1),ARG(1),VAL(1) DOUBLE PRECISION X,ZS,DZ,F,ARG,VAL IF(IROW-1)19,17,1 1 IF(DZ)2,17,2 2 N=NDIM IF(N-IROW)4,4,3 3 N=IROW 4 J=(X-ZS)/DZ+1.5D0 IF(J)5,5,6 5 J=1 6 IF(J-IROW)8,8,7 7 J=IROW 8 II=J JL=0 JR=0 DO 16 I=1,N ARG(I)=ZS+DFLOAT(II-1)*DZ IF(ICOL-2)9,10,10 9 VAL(I)=F(II) GOTO 11 10 VAL(2*I-1)=F(II) III=II+IROW VAL(2*I)=F(III) 11 IF(J+JR-IROW)12,15,12 12 IF(J-JL-1)13,14,13 13 IF((ARG(I)-X)*DZ)14,15,15 14 JR=JR+1 II=J+JR GOTO 16 15 JL=JL+1 II=J-JL 16 CONTINUE RETURN 17 ARG(1)=ZS VAL(1)=F(1) IF(ICOL-2)19,19,18 18 VAL(2)=F(2) 19 RETURN END SUBROUTINE DATSG(X,Z,F,WORK,IROW,ICOL,ARG,VAL,NDIM) DIMENSION Z(1),F(1),WORK(1),ARG(1),VAL(1) DOUBLE PRECISION X,Z,F,WORK,ARG,VAL,B,DELTA IF(IROW)11,11,1 1 N=NDIM IF(N-IROW)3,3,2 2 N=IROW 3 B=0.D0 DO 5 I=1,IROW DELTA=DABS(Z(I)-X) IF(DELTA-B)5,5,4 4 B=DELTA 5 WORK(I)=DELTA B=B+1.D0 DO 10 J=1,N DELTA=B DO 7 I=1,IROW IF(WORK(I)-DELTA)6,7,7 6 II=I DELTA=WORK(I) 7 CONTINUE ARG(J)=Z(II) IF(ICOL-1)8,9,8 8 VAL(2*J-1)=F(II) III=II+IROW VAL(2*J)=F(III) GOTO 10 9 VAL(J)=F(II) 10 WORK(II)=B 11 RETURN END SUBROUTINE DATSM(X,Z,F,IROW,ICOL,ARG,VAL,NDIM) DIMENSION Z(1),F(1),ARG(1),VAL(1) DOUBLE PRECISION X,Z,F,ARG,VAL IF(IROW-1)23,21,1 1 N=NDIM IF(N-IROW)3,3,2 2 N=IROW 3 IF(Z(IROW)-Z(1))5,4,4 4 J=IROW I=1 GOTO 6 5 I=IROW J=1 6 K=(J+I)/2 IF(X-Z(K))7,7,8 7 J=K GOTO 9 8 I=K 9 IF(IABS(J-I)-1)10,10,6 10 IF(DABS(Z(J)-X)-DABS(Z(I)-X))12,12,11 11 J=I 12 K=J JL=0 JR=0 DO 20 I=1,N ARG(I)=Z(K) IF(ICOL-1)14,14,13 13 VAL(2*I-1)=F(K) KK=K+IROW VAL(2*I)=F(KK) GOTO 15 14 VAL(I)=F(K) 15 JJR=J+JR IF(JJR-IROW)16,18,18 16 JJL=J-JL IF(JJL-1)19,19,17 17 IF(DABS(Z(JJR+1)-X)-DABS(Z(JJL-1)-X))19,19,18 18 JL=JL+1 K=J-JL GOTO 20 19 JR=JR+1 K=J+JR 20 CONTINUE RETURN 21 ARG(1)=Z(1) VAL(1)=F(1) IF(ICOL-2)23,22,23 22 VAL(2)=F(2) 23 RETURN END SUBROUTINE EIGEN(A,R,N,MV) DIMENSION A(1),R(1) 5 RANGE=1.0E-6 IF(MV-1) 10,25,10 10 IQ=-N DO 20 J=1,N IQ=IQ+N DO 20 I=1,N IJ=IQ+I R(IJ)=0.0 IF(I-J) 20,15,20 15 R(IJ)=1.0 20 CONTINUE 25 ANORM=0.0 DO 35 I=1,N DO 35 J=I,N IF(I-J) 30,35,30 30 IA=I+(J*J-J)/2 ANORM=ANORM+A(IA)*A(IA) 35 CONTINUE IF(ANORM) 165,165,40 40 ANORM=1.414*SQRT(ANORM) ANRMX=ANORM*RANGE/FLOAT(N) IND=0 THR=ANORM 45 THR=THR/FLOAT(N) 50 L=1 55 M=L+1 60 MQ=(M*M-M)/2 LQ=(L*L-L)/2 LM=L+MQ 62 IF( ABS(A(LM))-THR) 130,65,65 65 IND=1 LL=L+LQ MM=M+MQ X=0.5*(A(LL)-A(MM)) 68 Y=-A(LM)/ SQRT(A(LM)*A(LM)+X*X) IF(X) 70,75,75 70 Y=-Y 75 SINX=Y/ SQRT(2.0*(1.0+( SQRT(1.0-Y*Y)))) SINX2=SINX*SINX 78 COSX= SQRT(1.0-SINX2) COSX2=COSX*COSX SINCS =SINX*COSX ILQ=N*(L-1) IMQ=N*(M-1) DO 125 I=1,N IQ=(I*I-I)/2 IF(I-L) 80,115,80 80 IF(I-M) 85,115,90 85 IM=I+MQ GO TO 95 90 IM=M+IQ 95 IF(I-L) 100,105,105 100 IL=I+LQ GO TO 110 105 IL=L+IQ 110 X=A(IL)*COSX-A(IM)*SINX A(IM)=A(IL)*SINX+A(IM)*COSX A(IL)=X 115 IF(MV-1) 120,125,120 120 ILR=ILQ+I IMR=IMQ+I X=R(ILR)*COSX-R(IMR)*SINX R(IMR)=R(ILR)*SINX+R(IMR)*COSX R(ILR)=X 125 CONTINUE X=2.0*A(LM)*SINCS Y=A(LL)*COSX2+A(MM)*SINX2-X X=A(LL)*SINX2+A(MM)*COSX2+X A(LM)=(A(LL)-A(MM))*SINCS+A(LM)*(COSX2-SINX2) A(LL)=Y A(MM)=X 130 IF(M-N) 135,140,135 135 M=M+1 GO TO 60 140 IF(L-(N-1)) 145,150,145 145 L=L+1 GO TO 55 150 IF(IND-1) 160,155,160 155 IND=0 GO TO 50 160 IF(THR-ANRMX) 165,165,45 165 IQ=-N DO 185 I=1,N IQ=IQ+N LL=I+(I*I-I)/2 JQ=N*(I-2) DO 185 J=I,N JQ=JQ+N MM=J+(J*J-J)/2 IF(A(LL)-A(MM)) 170,185,185 170 X=A(LL) A(LL)=A(MM) A(MM)=X IF(MV-1) 175,185,175 175 DO 180 K=1,N ILR=IQ+K IMR=JQ+K X=R(ILR) R(ILR)=R(IMR) 180 R(IMR)=X 185 CONTINUE RETURN END SUBROUTINE ELI1(RES,X,CK) IF(X)2,1,2 1 RES=0. RETURN 2 IF(CK)4,3,4 3 RES=ALOG(ABS(X)+SQRT(1.+X*X)) GOTO 13 4 ANGLE=ABS(1./X) GEO=ABS(CK) ARI=1. PIM=0. 5 SQGEO=ARI*GEO AARI=ARI ARI=GEO+ARI ANGLE=-SQGEO/ANGLE+ANGLE SQGEO=SQRT(SQGEO) IF(ANGLE)7,6,7 6 ANGLE=SQGEO*1.E-8 7 TEST=AARI*1.E-4 IF(ABS(AARI-GEO)-TEST)10,10,8 8 GEO=SQGEO+SQGEO PIM=PIM+PIM IF(ANGLE)9,5,5 9 PIM=PIM+3.1415927 GOTO 5 10 IF(ANGLE)11,12,12 11 PIM=PIM+3.1415927 12 RES=(ATAN(ARI/ANGLE)+PIM)/ARI 13 IF(X)14,15,15 14 RES=-RES 15 RETURN END SUBROUTINE ELI2(R,X,CK,A,B) IF(X)2,1,2 1 R=0. RETURN 2 C=0. D=0.5 IF(CK)7,3,7 3 R=SQRT(1.+X*X) R=(A-B)*ABS(X)/R+B*ALOG(ABS(X)+R) 4 R=R+C*(A-B) IF(X)5,6,6 5 R=-R 6 RETURN 7 AN=(B+A)*0.5 AA=A R=B ANG=ABS(1./X) PIM=0. ISI=0 ARI=1. GEO=ABS(CK) 8 R=AA*GEO+R SGEO=ARI*GEO AA=AN AARI=ARI ARI=GEO+ARI AN=(R/ARI+AA)*0.5 AANG=ABS(ANG) ANG=-SGEO/ANG+ANG PIMA=PIM IF(ANG)10,9,11 9 ANG=-1.E-8*AANG 10 PIM=PIM+3.1415927 ISI=ISI+1 11 AANG=ARI*ARI+ANG*ANG P=D/SQRT(AANG) IF(ISI-4)13,12,12 12 ISI=ISI-4 13 IF(ISI-2)15,14,14 14 P=-P 15 C=C+P D=D*(AARI-GEO)*0.5/ARI IF(ABS(AARI-GEO)-1.E-4*AARI)17,17,16 16 SGEO=SQRT(SGEO) GEO=SGEO+SGEO PIM=PIM+PIMA ISI=ISI+ISI GOTO 8 17 R=(ATAN(ARI/ANG)+PIM)*AN/ARI C=C+D*ANG/AANG GOTO 4 END SUBROUTINE EXPI(X,RES,AUX) IF(X-1.)2,1,1 1 Y=1./X AUX=1.-Y*(((Y+3.377358E0)*Y+2.052156E0)*Y+2.709479E-1)/((((Y* 11.072553E0+5.716943E0)*Y+6.945239E0)*Y+2.593888E0)*Y+2.709496E-1) RES=AUX*Y*EXP(-X) RETURN 2 IF(X+3.)6,6,3 3 AUX=(((((((7.122452E-7*X-1.766345E-6)*X+2.928433E-5)*X-2.335379E-4 1)*X+1.664156E-3)*X-1.041576E-2)*X+5.555682E-2)*X-2.500001E-1)*X 2+9.999999E-1 RES=-1.E33 IF(X)4,5,4 4 RES=X*AUX-ALOG(ABS(X))-5.772157E-1 5 RETURN 6 IF(X+9.)8,8,7 7 AUX=1.-((((5.176245E-2*X+3.061037E0)*X+3.243665E1)*X+2.244234E2)*X 1+2.486697E2)/((((X+3.995161E0)*X+3.893944E1)*X+2.263818E1)*X 2+1.807837E2) GOTO 9 8 Y=9./X AUX=1.-Y*(((Y+7.659824E-1)*Y-7.271015E-1)*Y-1.080693E0)/((((Y 1*2.518750E0+1.122927E1)*Y+5.921405E0)*Y-8.666702E0)*Y-9.724216E0) 9 RES=AUX*EXP(-X)/X RETURN END SUBROUTINE EXSMO (X,NX,AL,A,B,C,S) DIMENSION X(1),S(1) IF(A) 140, 110, 140 110 IF(B) 140, 120, 140 120 IF(C) 140, 130, 140 130 C=X(1)-2.0*X(2)+X(3) B=X(2)-X(1)-1.5*C A=X(1)-B-0.5*C 140 BE=1.0-AL BECUB=BE*BE*BE ALCUB=AL*AL*AL DO 150 I=1,NX S(I)=A+B+0.5*C DIF=S(I)-X(I) A=X(I)+BECUB*DIF B=B+C-1.5*AL*AL*(2.0-AL)*DIF 150 C=C-ALCUB*DIF RETURN END SUBROUTINE FACTR(A,PER,N,IA,IER) DIMENSION A(1),PER(1) DOUBLE PRECISION DP DO 20 I=1,N X=0. IJ=I DO 10 J=1,N IF (ABS(A(IJ))-X)10,10,5 5 X=ABS(A(IJ)) 10 IJ=IJ+IA IF (X) 110,110,20 20 PER(I)=1./X I0=0 DO 100 I=1,N IM1=I-1 IP1=I+1 IPIVOT=I X=0. DO 50 K=I,N KI=I0+K DP=A(KI) IF (I-1) 110,40,25 25 KJ=K DO 30 J=1,IM1 IJ=I0+J DP=DP-1.D0*A(KJ)*A(IJ) 30 KJ=KJ+IA A(KI)=DP 40 IF (X-DABS(DP)*PER(K))45,50,50 45 IPIVOT=K X=DABS(DP)*PER(K) 50 CONTINUE IF (X)110,110,55 55 IF (IPIVOT-I) 110,70,57 57 KI=IPIVOT IJ=I DO 60 J=1,N X=A(IJ) A(IJ)=A(KI) A(KI)=X KI=KI+IA 60 IJ=IJ+IA PER(IPIVOT)=PER(I) 70 PER(I)=IPIVOT IF (I-N) 72,100,100 72 IJ=I0+I X=A(IJ) K0=I0+IA DO 90 K=IP1,N KI=I0+K A(KI)=A(KI)/X IF (I-1)110,90,75 75 IJ=I KI=K0+I DP=A(KI) DO 80 J=1,IM1 KJ=K0+J DP=DP-1.D0*A(IJ)*A(KJ) 80 IJ=IJ+IA A(KI)=DP 90 K0=K0+IA 100 I0=I0+IA IER=0 RETURN 110 IER=3 RETURN END SUBROUTINE FMCG(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) DIMENSION X(1),G(1),H(1) CALL FUNCT(N,X,F,G) KOUNT=0 IER=0 N1=N+1 1 DO 43 II=1,N1 KOUNT=KOUNT+1 OLDF=F GNRM=0. DO 2 J=1,N 2 GNRM=GNRM+G(J)*G(J) IF(GNRM)46,46,3 3 IF(II-1)4,4,6 4 DO 5 J=1,N 5 H(J)=-G(J) GO TO 8 6 AMBDA=GNRM/OLDG DO 7 J=1,N 7 H(J)=AMBDA*H(J)-G(J) 8 DY=0. HNRM=0. DO 9 J=1,N K=J+N H(K)=X(J) HNRM=HNRM+ABS(H(J)) 9 DY=DY+H(J)*G(J) IF(DY)10,42,42 10 SNRM=1./HNRM FY=F ALFA=2.*(EST-F)/DY AMBDA=SNRM IF(ALFA)13,13,11 11 IF(ALFA-AMBDA)12,13,13 12 AMBDA=ALFA 13 ALFA=0. 14 FX=FY DX=DY DO 15 I=1,N 15 X(I)=X(I)+AMBDA*H(I) CALL FUNCT(N,X,F,G) FY=F DY=0. DO 16 I=1,N 16 DY=DY+G(I)*H(I) IF(DY)17,38,20 17 IF(FY-FX)18,20,20 18 AMBDA=AMBDA+ALFA ALFA=AMBDA IF(HNRM*AMBDA-1.E10)14,14,19 19 IER=2 F=OLDF DO 100 J=1,N G(J)=H(J) K=N+J 100 X(J)=H(K) RETURN 20 T=0. 21 IF(AMBDA)22,38,22 22 Z=3.*(FX-FY)/AMBDA+DX+DY ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)23,27,27 23 DO 24 J=1,N K=N+J 24 X(J)=H(K) CALL FUNCT(N,X,F,G) 25 IF(IER)47,26,47 26 IER=-1 GOTO 1 27 W=ALFA*SQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA)270,271,270 270 ALFA=(DY-Z+W)/ALFA GO TO 272 271 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 272 ALFA=ALFA*AMBDA DO 28 I=1,N 28 X(I)=X(I)+(T-ALFA)*H(I) CALL FUNCT(N,X,F,G) IF(F-FX)29,29,30 29 IF(F-FY)38,38,30 30 DALFA=0. DO 31 I=1,N 31 DALFA=DALFA+G(I)*H(I) IF(DALFA)32,35,35 32 IF(F-FX)34,33,35 33 IF(DX-DALFA)34,38,34 34 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 21 35 IF(FY-F)37,36,37 36 IF(DY-DALFA)37,38,37 37 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 20 38 IF(OLDF-F+EPS)19,25,39 39 OLDG=GNRM T=0. DO 40 J=1,N K=J+N H(K)=X(J)-H(K) 40 T=T+ABS(H(K)) IF(KOUNT-N1)42,41,41 41 IF(T-EPS)45,45,42 42 IF(KOUNT-LIMIT)43,44,44 43 IER=0 GO TO 1 44 IER=1 IF(GNRM-EPS)46,46,47 45 IF(GNRM-EPS)46,46,25 46 IER=0 47 RETURN END SUBROUTINE FMFP(FUNCT,N,X,F,G,EST,EPS,LIMIT,IER,H) DIMENSION H(1),X(1),G(1) CALL FUNCT(N,X,F,G) IER=0 KOUNT=0 N2=N+N N3=N2+N N31=N3+1 1 K=N31 DO 4 J=1,N H(K)=1. NJ=N-J IF(NJ)5,5,2 2 DO 3 L=1,NJ KL=K+L 3 H(KL)=0. 4 K=KL+1 5 KOUNT=KOUNT +1 OLDF=F DO 9 J=1,N K=N+J H(K)=G(J) K=K+N H(K)=X(J) K=J+N3 T=0. DO 8 L=1,N T=T-G(L)*H(K) IF(L-J)6,7,7 6 K=K+N-L GO TO 8 7 K=K+1 8 CONTINUE 9 H(J)=T DY=0. HNRM=0. GNRM=0. DO 10 J=1,N HNRM=HNRM+ABS(H(J)) GNRM=GNRM+ABS(G(J)) 10 DY=DY+H(J)*G(J) IF(DY)11,51,51 11 IF(HNRM/GNRM-EPS)51,51,12 12 FY=F ALFA=2.*(EST-F)/DY AMBDA=1. IF(ALFA)15,15,13 13 IF(ALFA-AMBDA)14,15,15 14 AMBDA=ALFA 15 ALFA=0. 16 FX=FY DX=DY DO 17 I=1,N 17 X(I)=X(I)+AMBDA*H(I) CALL FUNCT(N,X,F,G) FY=F DY=0. DO 18 I=1,N 18 DY=DY+G(I)*H(I) IF(DY)19,36,22 19 IF(FY-FX)20,22,22 20 AMBDA=AMBDA+ALFA ALFA=AMBDA IF(HNRM*AMBDA-1.E10)16,16,21 21 IER=2 RETURN 22 T=0. 23 IF(AMBDA)24,36,24 24 Z=3.*(FX-FY)/AMBDA+DX+DY ALFA=AMAX1(ABS(Z),ABS(DX),ABS(DY)) DALFA=Z/ALFA DALFA=DALFA*DALFA-DX/ALFA*DY/ALFA IF(DALFA)51,25,25 25 W=ALFA*SQRT(DALFA) ALFA=DY-DX+W+W IF(ALFA) 250,251,250 250 ALFA=(DY-Z+W)/ALFA GO TO 252 251 ALFA=(Z+DY-W)/(Z+DX+Z+DY) 252 ALFA=ALFA*AMBDA DO 26 I=1,N 26 X(I)=X(I)+(T-ALFA)*H(I) CALL FUNCT(N,X,F,G) IF(F-FX)27,27,28 27 IF(F-FY)36,36,28 28 DALFA=0. DO 29 I=1,N 29 DALFA=DALFA+G(I)*H(I) IF(DALFA)30,33,33 30 IF(F-FX)32,31,33 31 IF(DX-DALFA)32,36,32 32 FX=F DX=DALFA T=ALFA AMBDA=ALFA GO TO 23 33 IF(FY-F)35,34,35 34 IF(DY-DALFA)35,36,35 35 FY=F DY=DALFA AMBDA=AMBDA-ALFA GO TO 22 36 IF(OLDF-F+EPS)51,38,38 38 DO 37 J=1,N K=N+J H(K)=G(J)-H(K) K=N+K 37 H(K)=X(J)-H(K) IER=0 IF(KOUNT-N)42,39,39 39 T=0. Z=0. DO 40 J=1,N K=N+J W=H(K) K=K+N T=T+ABS(H(K)) 40 Z=Z+W*H(K) IF(HNRM-EPS)41,41,42 41 IF(T-EPS)56,56,42 42 IF(KOUNT-LIMIT)43,50,50 43 ALFA=0. DO 47 J=1,N K=J+N3 W=0. DO 46 L=1,N KL=N+L W=W+H(KL)*H(K) IF(L-J)44,45,45 44 K=K+N-L GO TO 46 45 K=K+1 46 CONTINUE K=N+J ALFA=ALFA+W*H(K) 47 H(J)=W IF(Z*ALFA)48,1,48 48 K=N31 DO 49 L=1,N KL=N2+L DO 49 J=L,N NJ=N2+J H(K)=H(K)+H(KL)*H(NJ)/Z-H(L)*H(J)/ALFA 49 K=K+1 GO TO 5 50 IER=1 RETURN 51 DO 52 J=1,N K=N2+J 52 X(J)=H(K) CALL FUNCT(N,X,F,G) IF(GNRM-EPS)55,55,53 53 IF(IER)56,54,54 54 IER=-1 GOTO 1 55 IER=0 56 RETURN END SUBROUTINE FRAT(I,N,M,P,DATI,WGT,IER) DIMENSION P(1),DATI(1),IER(1) IP=IER(2) IQ=IER(3) IQM1=IQ-1 IPQ=IP+IQ T=DATI(I) J=I+N F=DATI(J) FNUM=P(J) J=J+N WGT=1. IF(DATI(2*N+1))2,2,1 1 WGT=DATI(J) 2 FDEN=P(J) F=F*FDEN-FNUM IF(FDEN)4,3,4 3 IER(1)=1 RETURN 4 WGT=WGT/(FDEN*FDEN) FNUM=-FNUM/FDEN J=IQM1 IF(IP-IQ)6,6,5 5 J=IP-1 6 CALL CNP(P(IQ),T,J) 7 IF(IQM1)10,10,8 8 DO 9 II=1,IQM1 J=II+IQ 9 P(II)=P(J)*FNUM 10 P(IPQ)=F IER(1)=0 RETURN END SUBROUTINE FORIF(FUN,N,M,A,B,IER) DIMENSION A(1),B(1) IER=0 20 IF(M) 30,40,40 30 IER=2 RETURN 40 IF(M-N) 60,60,50 50 IER=1 RETURN 60 AN=N COEF=2.0/(2.0*AN+1.0) CONST=3.141593*COEF S1=SIN(CONST) C1=COS(CONST) C=1.0 S=0.0 J=1 FUNZ=FUN(0.0) 70 U2=0.0 U1=0.0 AI=2*N 75 X=AI*CONST U0=FUN(X)+2.0*C*U1-U2 U2=U1 U1=U0 AI=AI-1.0 IF(AI) 80,80,75 80 A(J)=COEF*(FUNZ+C*U1-U2) B(J)=COEF*S*U1 IF(J-(M+1)) 90,100,100 90 Q=C1*C-S1*S S=C1*S+S1*C C=Q J=J+1 GO TO 70 100 A(1)=A(1)*0.5 RETURN END SUBROUTINE FORIT(FNT,N,M,A,B,IER) DIMENSION A(1),B(1),FNT(1) IER=0 20 IF(M) 30,40,40 30 IER=2 RETURN 40 IF(M-N) 60,60,50 50 IER=1 RETURN 60 AN=N COEF=2.0/(2.0*AN+1.0) CONST=3.141593*COEF S1=SIN(CONST) C1=COS(CONST) C=1.0 S=0.0 J=1 FNTZ=FNT(1) 70 U2=0.0 U1=0.0 I=2*N+1 75 U0=FNT(I)+2.0*C*U1-U2 U2=U1 U1=U0 I=I-1 IF(I-1) 80,80,75 80 A(J)=COEF*(FNTZ+C*U1-U2) B(J)=COEF*S*U1 IF(J-(M+1)) 90,100,100 90 Q=C1*C-S1*S S=C1*S+S1*C C=Q J=J+1 GO TO 70 100 A(1)=A(1)*0.5 RETURN END SUBROUTINE GAUSS(IX,S,AM,V) A=0.0 DO 50 I=1,12 CALL RANDU(IX,IY,Y) IX=IY 50 A=A+Y V=(A-6.0)*S+AM RETURN END SUBROUTINE GDATA (N,M,X,XBAR,STD,D,SUMSQ) DIMENSION X(1),XBAR(1),STD(1),D(1),SUMSQ(1) IF(M-1) 105, 105, 90 90 L1=0 DO 100 I=2,M L1=L1+N DO 100 J=1,N L=L1+J K=L-N 100 X(L)=X(K)*X(J) 105 MM=M+1 DF=N L=0 DO 115 I=1,MM XBAR(I)=0.0 DO 110 J=1,N L=L+1 110 XBAR(I)=XBAR(I)+X(L) 115 XBAR(I)=XBAR(I)/DF DO 130 I=1,MM 130 STD(I)=0.0 L=((MM+1)*MM)/2 DO 150 I=1,L 150 D(I)=0.0 DO 170 K=1,N L=0 DO 170 J=1,MM L2=N*(J-1)+K T2=X(L2)-XBAR(J) STD(J)=STD(J)+T2 DO 170 I=1,J L1=N*(I-1)+K T1=X(L1)-XBAR(I) L=L+1 170 D(L)=D(L)+T1*T2 L=0 DO 175 J=1,MM DO 175 I=1,J L=L+1 175 D(L)=D(L)-STD(I)*STD(J)/DF L=0 DO 180 I=1,MM L=L+I SUMSQ(I)=D(L) 180 STD(I)= SQRT( ABS(D(L))) L=0 DO 190 J=1,MM DO 190 I=1,J L=L+1 190 D(L)=D(L)/(STD(I)*STD(J)) DF=SQRT(DF-1.0) DO 200 I=1,MM 200 STD(I)=STD(I)/DF RETURN END SUBROUTINE GELB(R,A,M,N,MUD,MLD,EPS,IER) DIMENSION R(1),A(1) IF(MLD)47,1,1 1 IF(MUD)47,2,2 2 MC=1+MLD+MUD IF(MC+1-M-M)3,3,47 3 IF(MC-M)5,5,4 4 MC=M 5 MU=MC-MUD-1 ML=MC-MLD-1 MR=M-ML MZ=(MU*(MU+1))/2 MA=M*MC-(ML*(ML+1))/2 NM=N*M IER=0 PIV=0. IF(MLD)14,14,6 6 JJ=MA J=MA-MZ KST=J DO 9 K=1,KST TB=A(J) A(JJ)=TB TB=ABS(TB) IF(TB-PIV)8,8,7 7 PIV=TB 8 J=J-1 9 JJ=JJ-1 IF(MZ)14,14,10 10 JJ=1 J=1+MZ IC=1+MUD DO 13 I=1,MU DO 12 K=1,MC A(JJ)=0. IF(K-IC)11,11,12 11 A(JJ)=A(J) J=J+1 12 JJ=JJ+1 13 IC=IC+1 14 TOL=EPS*PIV KST=1 IDST=MC IC=MC-1 DO 38 K=1,M IF(K-MR-1)16,16,15 15 IDST=IDST-1 16 ID=IDST ILR=K+MLD IF(ILR-M)18,18,17 17 ILR=M 18 II=KST PIV=0. DO 22 I=K,ILR TB=ABS(A(II)) IF(TB-PIV)20,20,19 19 PIV=TB J=I JJ=II 20 IF(I-MR)22,22,21 21 ID=ID-1 22 II=II+ID IF(PIV)47,47,23 23 IF(IER)26,24,26 24 IF(PIV-TOL)25,25,26 25 IER=K-1 26 PIV=1./A(JJ) ID=J-K DO 27 I=K,NM,M II=I+ID TB=PIV*R(II) R(II)=R(I) 27 R(I)=TB II=KST J=JJ+IC DO 28 I=JJ,J TB=PIV*A(I) A(I)=A(II) A(II)=TB 28 II=II+1 IF(K-ILR)29,34,34 29 ID=KST II=K+1 MU=KST+1 MZ=KST+IC DO 33 I=II,ILR ID=ID+MC JJ=I-MR-1 IF(JJ)31,31,30 30 ID=ID-JJ 31 PIV=-A(ID) J=ID+1 DO 32 JJ=MU,MZ A(J-1)=A(J)+PIV*A(JJ) 32 J=J+1 A(J-1)=0. J=K DO 33 JJ=I,NM,M R(JJ)=R(JJ)+PIV*R(J) 33 J=J+M 34 KST=KST+MC IF(ILR-MR)36,35,35 35 IC=IC-1 36 ID=K-MR IF(ID)38,38,37 37 KST=KST-ID 38 CONTINUE IF(MC-1)46,46,39 39 IC=2 KST=MA+ML-MC+2 II=M DO 45 I=2,M KST=KST-MC II=II-1 J=II-MR IF(J)41,41,40 40 KST=KST+J 41 DO 43 J=II,NM,M TB=R(J) MZ=KST+IC-2 ID=J DO 42 JJ=KST,MZ ID=ID+1 42 TB=TB-A(JJ)*R(ID) 43 R(J)=TB IF(IC-MC)44,45,45 44 IC=IC+1 45 CONTINUE 46 RETURN 47 IER=-1 RETURN END SUBROUTINE GELG(R,A,M,N,EPS,IER) DIMENSION A(1),R(1) IF(M)23,23,1 1 IER=0 PIV=0. MM=M*M NM=N*M DO 3 L=1,MM TB=ABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L 3 CONTINUE TOL=EPS*PIV LST=1 DO 17 K=1,M IF(PIV)23,23,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 PIVI=1./A(I) J=(I-1)/M I=I-J*M-K J=J+1-K DO 8 L=K,NM,M LL=L+I TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB IF(K-M)9,18,18 9 LEND=LST+M-K IF(J)12,12,10 10 II=J*M DO 11 L=LST,LEND TB=A(L) LL=L+II A(L)=A(LL) 11 A(LL)=TB 12 DO 13 L=LST,MM,M LL=L+I TB=PIVI*A(LL) A(LL)=A(L) 13 A(L)=TB A(LST)=J PIV=0. LST=LST+1 J=0 DO 16 II=LST,LEND PIVI=-A(II) IST=II+M J=J+1 DO 15 L=IST,MM,M LL=L-J A(L)=A(L)+PIVI*A(LL) TB=ABS(A(L)) IF(TB-PIV)15,15,14 14 PIV=TB I=L 15 CONTINUE DO 16 L=K,NM,M LL=L+J 16 R(LL)=R(LL)+PIVI*R(L) 17 LST=LST+M 18 IF(M-1)23,22,19 19 IST=MM+M LST=M+1 DO 21 I=2,M II=LST-I IST=IST-LST L=IST-M L=A(L)+.5 DO 21 J=II,NM,M TB=R(J) LL=J DO 20 K=IST,MM,M LL=LL+1 20 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 21 R(K)=TB 22 RETURN 23 IER=-1 RETURN END SUBROUTINE GELS(R,A,M,N,EPS,IER,AUX) DIMENSION A(1),R(1),AUX(1) IF(M)24,24,1 1 IER=0 PIV=0. L=0 DO 3 K=1,M L=L+K TB=ABS(A(L)) IF(TB-PIV)3,3,2 2 PIV=TB I=L J=K 3 CONTINUE TOL=EPS*PIV LST=0 NM=N*M LEND=M-1 DO 18 K=1,M IF(PIV)24,24,4 4 IF(IER)7,5,7 5 IF(PIV-TOL)6,6,7 6 IER=K-1 7 LT=J-K LST=LST+K PIVI=1./A(I) DO 8 L=K,NM,M LL=L+LT TB=PIVI*R(LL) R(LL)=R(L) 8 R(L)=TB IF(K-M)9,19,19 9 LR=LST+(LT*(K+J-1))/2 LL=LR L=LST DO 14 II=K,LEND L=L+II LL=LL+1 IF(L-LR)12,10,11 10 A(LL)=A(LST) TB=A(L) GO TO 13 11 LL=L+LT 12 TB=A(LL) A(LL)=A(L) 13 AUX(II)=TB 14 A(L)=PIVI*TB A(LST)=LT PIV=0. LLST=LST LT=0 DO 18 II=K,LEND PIVI=-AUX(II) LL=LLST LT=LT+1 DO 15 LLD=II,LEND LL=LL+LLD L=LL+LT 15 A(L)=A(L)+PIVI*A(LL) LLST=LLST+II LR=LLST+LT TB=ABS(A(LR)) IF(TB-PIV)17,17,16 16 PIV=TB I=LR J=II+1 17 DO 18 LR=K,NM,M LL=LR+LT 18 R(LL)=R(LL)+PIVI*R(LR) 19 IF(LEND)24,23,20 20 II=M DO 22 I=2,M LST=LST-II II=II-1 L=A(LST)+.5 DO 22 J=II,NM,M TB=R(J) LL=J K=LST DO 21 LT=II,LEND LL=LL+1 K=K+LT 21 TB=TB-A(K)*R(LL) K=J+L R(J)=R(K) 22 R(K)=TB 23 RETURN 24 IER=-1 RETURN END SUBROUTINE GMADD(A,B,R,N,M) DIMENSION A(1),B(1),R(1) NM=N*M DO 10 I=1,NM 10 R(I)=A(I)+B(I) RETURN END SUBROUTINE GMMMA(XX,GX,IER) IF(XX-57.)6,6,4 4 IER=2 GX=1.E33 RETURN 6 X=XX ERR=1.0E-6 IER=0 GX=1.0 IF(X-2.0)50,50,15 10 IF(X-2.0)110,110,15 15 X=X-1.0 GX=GX*X GO TO 10 50 IF(X-1.0)60,120,110 60 IF(X-ERR)62,62,80 62 Y=FLOAT(INT(X))-X IF(ABS(Y)-ERR)130,130,64 64 IF(1.0-Y-ERR)130,130,70 70 IF(X-1.0)80,80,110 80 GX=GX/X X=X+1.0 GO TO 70 110 Y=X-1.0 GY=1.0+Y*(-0.5771017+Y*(+0.9858540+Y*(-0.8764218+Y*(+0.8328212+ 1Y*(-0.5684729+Y*(+0.2548205+Y*(-0.05149930))))))) GX=GX*GY 120 RETURN 130 IER=1 RETURN END SUBROUTINE GMPRD(A,B,R,N,M,L) DIMENSION A(1),B(1),R(1) IR=0 IK=-M DO 10 K=1,L IK=IK+M DO 10 J=1,N IR=IR+1 JI=J-N IB=IK R(IR)=0 DO 10 I=1,M JI=JI+N IB=IB+1 10 R(IR)=R(IR)+A(JI)*B(IB) RETURN END SUBROUTINE GMSUB(A,B,R,N,M) DIMENSION A(1),B(1),R(1) NM=N*M DO 10 I=1,NM 10 R(I)=A(I)-B(I) RETURN END SUBROUTINE GMTRA(A,R,N,M) DIMENSION A(1),R(1) IR=0 DO 10 I=1,N IJ=I-N DO 10 J=1,M IJ=IJ+N IR=IR+1 10 R(IR)=A(IJ) RETURN END SUBROUTINE GTPRD(A,B,R,N,M,L) DIMENSION A(1),B(1),R(1) IR=0 IK=-N DO 10 K=1,L IJ=0 IK=IK+N DO 10 J=1,M IB=IK IR=IR+1 R(IR)=0 DO 10 I=1,N IJ=IJ+1 IB=IB+1 10 R(IR)=R(IR)+A(IJ)*B(IB) RETURN END SUBROUTINE HARM(A,M,INV,S,IFSET, IFERR) DIMENSION A(1),INV(1),S(1),N(3),M(3),NP(3),W(2),W2(2),W3(2) EQUIVALENCE (N1,N(1)),(N2,N(2)),(N3,N(3)) 10 IF( IABS(IFSET) - 1) 900,900,12 12 MTT=MAX0(M(1),M(2),M(3)) -2 ROOT2 = SQRT(2.) IF (MTT-MT ) 14,14,13 13 IFERR=1 RETURN 14 IFERR=0 M1=M(1) M2=M(2) M3=M(3) N1=2**M1 N2=2**M2 N3=2**M3 16 IF(IFSET) 18,18,20 18 NX= N1*N2*N3 FN = NX DO 19 I = 1,NX A(2*I-1) = A(2*I-1)/FN 19 A(2*I) = -A(2*I)/FN 20 NP(1)=N1*2 NP(2)= NP(1)*N2 NP(3)=NP(2)*N3 DO 250 ID=1,3 IL = NP(3)-NP(ID) IL1 = IL+1 MI = M(ID) IF (MI)250,250,30 30 IDIF=NP(ID) KBIT=NP(ID) MEV = 2*(MI/2) IF (MI - MEV )60,60,40 40 KBIT=KBIT/2 KL=KBIT-2 DO 50 I=1,IL1,IDIF KLAST=KL+I DO 50 K=I,KLAST,2 KD=K+KBIT T=A(KD) A(KD)=A(K)-T A(K)=A(K)+T T=A(KD+1) A(KD+1)=A(K+1)-T 50 A(K+1)=A(K+1)+T IF (MI - 1)250,250,52 52 LFIRST =3 JLAST=1 GO TO 70 60 LFIRST = 2 JLAST=0 70 DO 240 L=LFIRST,MI,2 JJDIF=KBIT KBIT=KBIT/4 KL=KBIT-2 DO 80 I=1,IL1,IDIF KLAST=I+KL DO 80 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT T=A(K2) A(K2)=A(K)-T A(K)=A(K)+T T=A(K2+1) A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T T=A(K3) A(K3)=A(K1)-T A(K1)=A(K1)+T T=A(K3+1) A(K3+1)=A(K1+1)-T A(K1+1)=A(K1+1)+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T = A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 80 A(K2+1)=A(K2+1)+T IF (JLAST) 235,235,82 82 JJ=JJDIF +1 ILAST= IL +JJ DO 85 I = JJ,ILAST,IDIF KLAST = KL+I DO 85 K=I,KLAST,2 K1 = K+KBIT K2 = K1+KBIT K3 = K2+KBIT R =-A(K2+1) T = A(K2) A(K2) = A(K)-R A(K) = A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T AWR=A(K1)-A(K1+1) AWI = A(K1+1)+A(K1) R=-A(K3)-A(K3+1) T=A(K3)-A(K3+1) A(K3)=(AWR-R)/ROOT2 A(K3+1)=(AWI-T)/ROOT2 A(K1)=(AWR+R)/ROOT2 A(K1+1)=(AWI+T)/ROOT2 T= A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 85 A(K2+1)=A(K2+1)+T IF(JLAST-1) 235,235,90 90 JJ= JJ + JJDIF DO 230 J=2,JLAST 96 I=INV(J+1) 98 IC=NT-I W(1)=S(IC) W(2)=S(I) I2=2*I I2C=NT-I2 IF(I2C)120,110,100 100 W2(1)=S(I2C) W2(2)=S(I2) GO TO 130 110 W2(1)=0. W2(2)=1. GO TO 130 120 I2CC = I2C+NT I2C=-I2C W2(1)=-S(I2C) W2(2)=S(I2CC) 130 I3=I+I2 I3C=NT-I3 IF(I3C)160,150,140 140 W3(1)=S(I3C) W3(2)=S(I3) GO TO 200 150 W3(1)=0. W3(2)=1. GO TO 200 160 I3CC=I3C+NT IF(I3CC)190,180,170 170 I3C=-I3C W3(1)=-S(I3C) W3(2)=S(I3CC) GO TO 200 180 W3(1)=-1. W3(2)=0. GO TO 200 190 I3CCC=NT+I3CC I3CC = -I3CC W3(1)=-S(I3CCC) W3(2)=-S(I3CC) 200 ILAST=IL+JJ DO 220 I=JJ,ILAST,IDIF KLAST=KL+I DO 220 K=I,KLAST,2 K1=K+KBIT K2=K1+KBIT K3=K2+KBIT R=A(K2)*W2(1)-A(K2+1)*W2(2) T=A(K2)*W2(2)+A(K2+1)*W2(1) A(K2)=A(K)-R A(K)=A(K)+R A(K2+1)=A(K+1)-T A(K+1)=A(K+1)+T R=A(K3)*W3(1)-A(K3+1)*W3(2) T=A(K3)*W3(2)+A(K3+1)*W3(1) AWR=A(K1)*W(1)-A(K1+1)*W(2) AWI=A(K1)*W(2)+A(K1+1)*W(1) A(K3)=AWR-R A(K3+1)=AWI-T A(K1)=AWR+R A(K1+1)=AWI+T T=A(K1) A(K1)=A(K)-T A(K)=A(K)+T T=A(K1+1) A(K1+1)=A(K+1)-T A(K+1)=A(K+1)+T R=-A(K3+1) T=A(K3) A(K3)=A(K2)-R A(K2)=A(K2)+R A(K3+1)=A(K2+1)-T 220 A(K2+1)=A(K2+1)+T 230 JJ=JJDIF+JJ 235 JLAST=4*JLAST+3 240 CONTINUE 250 CONTINUE NTSQ=NT*NT M3MT=M3-MT 350 IF(M3MT) 370,360,360 360 IGO3=1 N3VNT=N3/NT MINN3=NT GO TO 380 370 IGO3=2 N3VNT=1 NTVN3=NT/N3 MINN3=N3 380 JJD3 = NTSQ/N3 M2MT=M2-MT 450 IF (M2MT)470,460,460 460 IGO2=1 N2VNT=N2/NT MINN2=NT GO TO 480 470 IGO2 = 2 N2VNT=1 NTVN2=NT/N2 MINN2=N2 480 JJD2=NTSQ/N2 M1MT=M1-MT 550 IF(M1MT)570,560,560 560 IGO1=1 N1VNT=N1/NT MINN1=NT GO TO 580 570 IGO1=2 N1VNT=1 NTVN1=NT/N1 MINN1=N1 580 JJD1=NTSQ/N1 600 JJ3=1 J=1 DO 880 JPP3=1,N3VNT IPP3=INV(JJ3) DO 870 JP3=1,MINN3 GO TO (610,620),IGO3 610 IP3=INV(JP3)*N3VNT GO TO 630 620 IP3=INV(JP3)/NTVN3 630 I3=(IPP3+IP3)*N2 700 JJ2=1 DO 870 JPP2=1,N2VNT IPP2=INV(JJ2)+I3 DO 860 JP2=1,MINN2 GO TO (710,720),IGO2 710 IP2=INV(JP2)*N2VNT GO TO 730 720 IP2=INV(JP2)/NTVN2 730 I2=(IPP2+IP2)*N1 800 JJ1=1 DO 860 JPP1=1,N1VNT IPP1=INV(JJ1)+I2 DO 850 JP1=1,MINN1 GO TO (810,820),IGO1 810 IP1=INV(JP1)*N1VNT GO TO 830 820 IP1=INV(JP1)/NTVN1 830 I=2*(IPP1+IP1)+1 IF (J-I) 840,850,850 840 T=A(I) A(I)=A(J) A(J)=T T=A(I+1) A(I+1)=A(J+1) A(J+1)=T 850 J=J+2 860 JJ1=JJ1+JJD1 870 JJ2=JJ2+JJD2 880 JJ3 = JJ3+JJD3 890 IF(IFSET)891,895,895 891 DO 892 I = 1,NX 892 A(2*I) = -A(2*I) 895 RETURN 900 MT=MAX0(M(1),M(2),M(3)) -2 MT = MAX0(2,MT) 904 IF (MT-18) 906,906,13 906 IFERR=0 NT=2**MT NTV2=NT/2 910 THETA=.7853981634 JSTEP=NT JDIF=NTV2 S(JDIF)=SIN(THETA) DO 950 L=2,MT THETA=THETA/2. JSTEP2=JSTEP JSTEP=JDIF JDIF=JSTEP/2 S(JDIF)=SIN(THETA) JC1=NT-JDIF S(JC1)=COS(THETA) JLAST=NT-JSTEP2 IF(JLAST - JSTEP) 950,920,920 920 DO 940 J=JSTEP,JLAST,JSTEP JC=NT-J JD=J+JDIF 940 S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC) 950 CONTINUE 960 MTLEXP=NTV2 LM1EXP=1 INV(1)=0 DO 980 L=1,MT INV(LM1EXP+1) = MTLEXP DO 970 J=2,LM1EXP JJ=J+LM1EXP 970 INV(JJ)=INV(J)+MTLEXP MTLEXP=MTLEXP/2 980 LM1EXP=LM1EXP*2 982 IF(IFSET)12,895,12 END SUBROUTINE HEP(Y,X,N) DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN 2 Y(2)=X+X IF(N-1)1,1,3 3 DO 4 I=2,N F=X*Y(I)-FLOAT(I-1)*Y(I-1) 4 Y(I+1)=F+F RETURN END SUBROUTINE HEPS(Y,X,C,N) DIMENSION C(1) IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1. H1=X+X DO 4 I=2,N H2=X*H1-FLOAT(I-1)*H0 H0=H1 H1=H2+H2 4 Y=Y+C(I)*H0 RETURN END SUBROUTINE HPCG(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1) N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0. DO 1 I=1,NDIM AUX(16,I)=0. AUX(15,I)=DERY(I) 1 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))3,2,4 2 IHLF=12 GOTO 4 3 IHLF=13 4 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,5,6 5 IF(IHLF)7,7,6 6 RETURN 7 DO 8 I=1,NDIM 8 AUX(8,I)=DERY(I) ISW=1 GOTO 100 9 X=X+H DO 10 I=1,NDIM 10 AUX(2,I)=Y(I) 11 IHLF=IHLF+1 X=X-H DO 12 I=1,NDIM 12 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW=2 GOTO 100 13 X=X+H CALL FCT(X,Y,DERY) N=2 DO 14 I=1,NDIM AUX(2,I)=Y(I) 14 AUX(9,I)=DERY(I) ISW=3 GOTO 100 15 DELT=0. DO 16 I=1,NDIM 16 DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I)) DELT=.06666667*DELT IF(DELT-PRMT(4))19,19,17 17 IF(IHLF-10)11,18,18 18 IHLF=11 X=X+H GOTO 4 19 X=X+H CALL FCT(X,Y,DERY) DO 20 I=1,NDIM AUX(3,I)=Y(I) 20 AUX(10,I)=DERY(I) N=3 ISW=4 GOTO 100 21 N=1 X=X+H CALL FCT(X,Y,DERY) X=PRMT(1) DO 22 I=1,NDIM AUX(11,I)=DERY(I) 220Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 23 X=X+H N=N+1 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))6,24,6 24 IF(N-4)25,200,200 25 DO 26 I=1,NDIM AUX(N,I)=Y(I) 26 AUX(N+7,I)=DERY(I) IF(N-3)27,29,200 27 DO 28 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 28 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 23 29 DO 30 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 30 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 23 100 DO 101 I=1,NDIM Z=H*AUX(N+7,I) AUX(5,I)=Z 101 Y(I)=AUX(N,I)+.4*Z Z=X+.4*H CALL FCT(Z,Y,DERY) DO 102 I=1,NDIM Z=H*DERY(I) AUX(6,I)=Z 102 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*Z Z=X+.4557372*H CALL FCT(Z,Y,DERY) DO 103 I=1,NDIM Z=H*DERY(I) AUX(7,I)=Z 103 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*Z Z=X+H CALL FCT(Z,Y,DERY) DO 104 I=1,NDIM 1040Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) GOTO(9,13,15,21),ISW 200 ISTEP=3 201 IF(N-8)204,202,204 202 DO 203 N=2,7 DO 203 I=1,NDIM AUX(N-1,I)=AUX(N,I) 203 AUX(N+6,I)=AUX(N+7,I) N=7 204 N=N+1 DO 205 I=1,NDIM AUX(N-1,I)=Y(I) 205 AUX(N+6,I)=DERY(I) X=X+H 206 ISTEP=ISTEP+1 DO 207 I=1,NDIM 0DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 207 AUX(16,I)=DELT CALL FCT(X,Y,DERY) DO 208 I=1,NDIM 0DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 208 Y(I)=DELT+.07438017*AUX(16,I) DELT=0. DO 209 I=1,NDIM 209 DELT=DELT+AUX(15,I)*ABS(AUX(16,I)) IF(DELT-PRMT(4))210,222,222 210 CALL FCT(X,Y,DERY) CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))212,211,212 211 IF(IHLF-11)213,212,212 212 RETURN 213 IF(H*(X-PRMT(2)))214,212,212 214 IF(ABS(X-PRMT(2))-.1*ABS(H))212,215,215 215 IF(DELT-.02*PRMT(4))216,216,201 216 IF(IHLF)201,201,217 217 IF(N-7)201,218,218 218 IF(ISTEP-4)201,219,219 219 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)201,220,201 220 H=H+H IHLF=IHLF-1 ISTEP=0 DO 221 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 2210AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 201 222 IHLF=IHLF+1 IF(IHLF-10)223,223,210 223 H=.5*H ISTEP=0 DO 224 I=1,NDIM 0Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 224 AUX(N+4,I)=AUX(N+5,I) X=X-H DELT=X-(H+H) CALL FCT(DELT,Y,DERY) DO 225 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 225 Y(I)=AUX(N-4,I) DELT=DELT-(H+H) CALL FCT(DELT,Y,DERY) DO 226 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 226 AUX(N+3,I)=DERY(I) GOTO 206 END SUBROUTINE HPCL(PRMT,Y,DERY,NDIM,IHLF,AFCT,FCT,OUTP,AUX,A) DIMENSION PRMT(1),Y(1),DERY(1),AUX(16,1),A(1) GOTO 100 1 CALL AFCT(X,A) CALL FCT(X,DERY) DO 3 M=1,NDIM LL=M-NDIM HS=0. DO 2 L=1,NDIM LL=LL+NDIM 2 HS=HS+A(LL)*Y(L) 3 DERY(M)=HS+DERY(M) GOTO(105,202,204,206,115,122,125,308,312,327,329,128),ISW2 100 N=1 IHLF=0 X=PRMT(1) H=PRMT(3) PRMT(5)=0. DO 101 I=1,NDIM AUX(16,I)=0. AUX(15,I)=DERY(I) 101 AUX(1,I)=Y(I) IF(H*(PRMT(2)-X))103,102,104 102 IHLF=12 GOTO 104 103 IHLF=13 104 ISW2=1 GOTO 1 105 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,106,107 106 IF(IHLF)108,108,107 107 RETURN 108 DO 109 I=1,NDIM 109 AUX(8,I)=DERY(I) ISW1=1 GOTO 200 110 X=X+H DO 111 I=1,NDIM 111 AUX(2,I)=Y(I) 112 IHLF=IHLF+1 X=X-H DO 113 I=1,NDIM 113 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW1=2 GOTO 200 114 X=X+H ISW2=5 GOTO 1 115 N=2 DO 116 I=1,NDIM AUX(2,I)=Y(I) 116 AUX(9,I)=DERY(I) ISW1=3 GOTO 200 117 DELT=0. DO 118 I=1,NDIM 118 DELT=DELT+AUX(15,I)*ABS(Y(I)-AUX(4,I)) DELT=.06666667*DELT IF(DELT-PRMT(4))121,121,119 119 IF(IHLF-10)112,120,120 120 IHLF=11 X=X+H GOTO 104 121 X=X+H ISW2=6 GOTO 1 122 DO 123 I=1,NDIM AUX(3,I)=Y(I) 123 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 200 124 N=1 X=X+H ISW2=7 GOTO 1 125 X=PRMT(1) DO 126 I=1,NDIM AUX(11,I)=DERY(I) 1260Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 127 X=X+H N=N+1 ISW2=12 GOTO 1 128 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))107,129,107 129 IF(N-4)130,300,300 130 DO 131 I=1,NDIM AUX(N,I)=Y(I) 131 AUX(N+7,I)=DERY(I) IF(N-3)132,134,300 132 DO 133 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 133 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 127 134 DO 135 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 135 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 127 200 Z=X DO 201 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 201 Y(I)=AUX(N,I)+.4*X X=Z+.4*H ISW2=2 GOTO 1 202 DO 203 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 203 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X X=Z+.4557372*H ISW2=3 GOTO 1 204 DO 205 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 205 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X X=Z+H ISW2=4 GOTO 1 206 DO 207 I=1,NDIM 2070Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) X=Z GOTO(110,114,117,124),ISW1 300 ISTEP=3 301 IF(N-8)304,302,304 302 DO 303 N=2,7 DO 303 I=1,NDIM AUX(N-1,I)=AUX(N,I) 303 AUX(N+6,I)=AUX(N+7,I) N=7 304 N=N+1 DO 305 I=1,NDIM AUX(N-1,I)=Y(I) 305 AUX(N+6,I)=DERY(I) X=X+H 306 ISTEP=ISTEP+1 DO 307 I=1,NDIM 0DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 307 AUX(16,I)=DELT ISW2=8 GOTO 1 308 DO 309 I=1,NDIM 0DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 309 Y(I)=DELT+.07438017*AUX(16,I) DELT=0. DO 310 I=1,NDIM 310 DELT=DELT+AUX(15,I)*ABS(AUX(16,I)) IF(DELT-PRMT(4))311,324,324 311 ISW2=9 GOTO 1 312 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))314,313,314 313 IF(IHLF-11)315,314,314 314 RETURN 315 IF(H*(X-PRMT(2)))316,314,314 316 IF(ABS(X-PRMT(2))-.1*ABS(H))314,317,317 317 IF(DELT-.02*PRMT(4))318,318,301 318 IF(IHLF)301,301,319 319 IF(N-7)301,320,320 320 IF(ISTEP-4)301,321,321 321 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)301,322,301 322 H=H+H IHLF=IHLF-1 ISTEP=0 DO 323 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 3230AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 301 324 IHLF=IHLF+1 IF(IHLF-10)325,325,311 325 H=.5*H ISTEP=0 DO 326 I=1,NDIM 0Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 326 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=10 GOTO 1 327 DO 328 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 328 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=11 GOTO 1 329 X=DELT DO 330 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 330 AUX(N+3,I)=DERY(I) GOTO 306 END SUBROUTINE HSBG(N,A,IA) DIMENSION A(1) DOUBLE PRECISION S L=N NIA=L*IA LIA=NIA-IA 20 IF(L-3) 360,40,40 40 LIA=LIA-IA L1=L-1 L2=L1-1 ISUB=LIA+L IPIV=ISUB-IA PIV=ABS(A(IPIV)) IF(L-3) 90,90,50 50 M=IPIV-IA DO 80 I=L,M,IA T=ABS(A(I)) IF(T-PIV) 80,80,60 60 IPIV=I PIV=T 80 CONTINUE 90 IF(PIV) 100,320,100 100 IF(PIV-ABS(A(ISUB))) 180,180,120 120 M=IPIV-L DO 140 I=1,L J=M+I T=A(J) K=LIA+I A(J)=A(K) 140 A(K)=T M=L2-M/IA DO 160 I=L1,NIA,IA T=A(I) J=I-M A(I)=A(J) 160 A(J)=T 180 DO 200 I=L,LIA,IA 200 A(I)=A(I)/A(ISUB) J=-IA DO 240 I=1,L2 J=J+IA LJ=L+J DO 220 K=1,L1 KJ=K+J KL=K+LIA 220 A(KJ)=A(KJ)-A(LJ)*A(KL) 240 CONTINUE K=-IA DO 300 I=1,N K=K+IA LK=K+L1 S=A(LK) LJ=L-IA DO 280 J=1,L2 JK=K+J LJ=LJ+IA 280 S=S+A(LJ)*A(JK)*1.0D0 300 A(LK)=S DO 310 I=L,LIA,IA 310 A(I)=0.0 320 L=L1 GO TO 20 360 RETURN END SUBROUTINE INUE(X,N,ZI,RI) DIMENSION RI(1) IF(N)10,10,1 1 FN=N+N Q1=X/FN IF(ABS(X)-5.E-4)6,6,2 2 A0=1. A1=0. B0=0. B1=1. FI=FN 3 FI=FI+2. AN=FI/ABS(X) A=AN*A1+A0 B=AN*B1+B0 A0=A1 B0=B1 A1=A B1=B Q0=Q1 Q1=A/B IF(ABS((Q1-Q0)/Q1)-1.E-6)4,4,3 4 IF(X)5,6,6 5 Q1=-Q1 6 K=N 7 Q1=X/(FN+X*Q1) RI(K)=Q1 FN=FN-2. K=K-1 IF(K)8,8,7 8 FI=ZI DO 9 I=1,N FI=FI*RI(I) 9 RI(I)=FI 10 RETURN END SUBROUTINE I0(X,RI0) RI0=ABS(X) IF(RI0-3.75)1,1,2 1 Z=X*X*7.111111E-2 RI0=((((( 4.5813E-3*Z+3.60768E-2)*Z+2.659732E-1)*Z+1.206749E0)*Z 1+3.089942E0)*Z+3.515623E0)*Z+1. RETURN 2 Z=3.75/RI0 RI0= EXP(RI0)/SQRT(RI0)*((((((((3.92377E-3*Z-1.647633E-2)*Z 1+2.635537E-2)*Z-2.057706E-2)*Z+9.16281E-3)*Z-1.57565E-3)*Z 2+2.25319E-3)*Z+1.328592E-2)*Z+3.989423E-1) RETURN END SUBROUTINE JELF(SN,CN,DN,X,SCK) DIMENSION ARI(12),GEO(12) CM=SCK Y=X IF(SCK)3,1,4 1 D=EXP(X) A=1./D B=A+D CN=2./B DN=CN SN=TANH(X) 2 RETURN 3 D=1.-SCK CM=-SCK/D D=SQRT(D) Y=D*X 4 A=1. DN=1. DO 6 I=1,12 L=I ARI(I)=A CM=SQRT(CM) GEO(I)=CM C=(A+CM)*.5 IF(ABS(A-CM)-1.E-4*A)7,7,5 5 CM=A*CM 6 A=C 7 Y=C*Y SN=SIN(Y) CN=COS(Y) IF(SN)8,13,8 8 A=CN/SN C=A*C DO 9 I=1,L K=L-I+1 B=ARI(K) A=C*A C=DN*C DN=(GEO(K)+A)/(B+A) 9 A=C/B A=1./SQRT(C*C+1.) IF(SN)10,11,11 10 SN=-A GOTO 12 11 SN=A 12 CN=C*SN 13 IF(SCK)14,2,2 14 A=DN DN=CN CN=A SN=SN/D RETURN END SUBROUTINE KOLMO(X,N,Z,PROB,IFCOD,U,S,IER) DIMENSION X(1) IER=0 DO 5 I=2,N IF(X(I)-X(I-1))1,5,5 1 TEMP=X(I) IM=I-1 DO 3 J=1,IM L=I-J IF(TEMP-X(L))2,4,4 2 X(L+1)=X(L) 3 CONTINUE X(1)=TEMP GO TO 5 4 X(L+1)=TEMP 5 CONTINUE NM1=N-1 XN=N DN=0.0 FS=0.0 IL=1 6 DO 7 I=IL,NM1 J=I IF(X(J)-X(J+1))9,7,9 7 CONTINUE 8 J=N 9 IL=J+1 FI=FS FS=FLOAT(J)/XN IF(IFCOD-2)10,13,17 10 IF(S)11,11,12 11 IER=1 GO TO 29 12 Z =(X(J)-U)/S CALL NDTR(Z,Y,D) GO TO 27 13 IF(S)11,11,14 14 Z=(X(J)-U)/S+1.0 IF(Z)15,15,16 15 Y=0.0 GO TO 27 16 Y=1.-EXP(-Z) GO TO 27 17 IF(IFCOD-4)18,20,26 18 IF(S)19,11,19 19 Y=ATAN((X(J)-U)/S)*0.3183099+0.5 GO TO 27 20 IF(S-U)11,11,21 21 IF(X(J)-U)22,22,23 22 Y=0.0 GO TO 27 23 IF(X(J)-S)25,25,24 24 Y=1.0 GO TO 27 25 Y=(X(J)-U)/(S-U) GO TO 27 26 IER=1 GO TO 29 27 EI=ABS(Y-FI) ES=ABS(Y-FS) DN=AMAX1(DN,EI,ES) IF(IL-N)6,8,28 28 Z=DN*SQRT(XN) CALL SMIRN(Z,PROB) PROB=1.0-PROB 29 RETURN END SUBROUTINE KOLM2(X,Y,N,M,Z,PROB) DIMENSION X(1),Y(1) DO 5 I=2,N IF(X(I)-X(I-1))1,5,5 1 TEMP=X(I) IM=I-1 DO 3 J=1,IM L=I-J IF(TEMP-X(L))2,4,4 2 X(L+1)=X(L) 3 CONTINUE X(1)=TEMP GO TO 5 4 X(L+1)=TEMP 5 CONTINUE DO 10 I=2,M IF(Y(I)-Y(I-1))6,10,10 6 TEMP=Y(I) IM=I-1 DO 8 J=1,IM L=I-J IF(TEMP-Y(L))7,9,9 7 Y(L+1)=Y(L) 8 CONTINUE Y(1)=TEMP GO TO 10 9 Y(L+1)=TEMP 10 CONTINUE XN=FLOAT(N) XN1=1./XN XM=FLOAT(M) XM1=1./XM D=0.0 I=0 J=0 K=0 L=0 11 IF(X(I+1)-Y(J+1))12,13,18 12 K=1 GO TO 14 13 K=0 14 I=I+1 IF(I-N)15,21,21 15 IF(X(I+1)-X(I))14,14,16 16 IF(K)17,18,17 17 D=AMAX1(D,ABS(FLOAT(I)*XN1-FLOAT(J)*XM1)) IF(L)22,11,22 18 J=J+1 IF(J-M)19,20,20 19 IF(Y(J+1)-Y(J))18,18,17 20 L=1 GO TO 17 21 L=1 GO TO 16 22 Z=D*SQRT((XN*XM)/(XN+XM)) CALL SMIRN(Z,PROB) PROB=1.0-PROB RETURN END SUBROUTINE KRANK(A,B,R,N,TAU,SD,Z,NR) DIMENSION A(1),B(1),R(1) SD=0.0 Z=0.0 FN=N FN1=N*(N-1) IF(NR-1) 5, 10, 5 5 CALL RANK (A,R,N) CALL RANK (B,R(N+1),N) GO TO 40 10 DO 20 I=1,N 20 R(I)=A(I) DO 30 I=1,N J=I+N 30 R(J)=B(I) 40 ISORT=0 DO 50 I=2,N IF(R(I)-R(I-1)) 45,50,50 45 ISORT=ISORT+1 RSAVE=R(I) R(I)=R(I-1) R(I-1)=RSAVE I2=I+N SAVER=R(I2) R(I2)=R(I2-1) R(I2-1)=SAVER 50 CONTINUE IF(ISORT) 40,55,40 55 S=0.0 NM=N-1 DO 60 I=1,NM J=N+I DO 60 L=I,N K=N+L IF(R(K)-R(J)) 56,60,57 56 S=S-1.0 GO TO 60 57 S=S+1.0 60 CONTINUE KT=2 CALL TIE(R,N,KT,TA) CALL TIE(R(N+1),N,KT,TB) IF(TA) 70,65,70 65 IF(TB) 70,67,70 67 TAU=S/(0.5*FN1) GO TO 80 70 TAU=S/((SQRT(0.5*FN1-TA))*(SQRT(0.5*FN1-TB))) 80 IF(N-10) 90,85,85 85 SD=(SQRT((2.0*(FN+FN+5.0))/(9.0*FN1))) Z=TAU/SD 90 RETURN END SUBROUTINE LAP(Y,X,N) DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN 2 Y(2)=1.-X IF(N-1)1,1,3 3 T=1.+X DO 4 I=2,N 4 Y(I+1)=Y(I)-Y(I-1)+Y(I)-(T*Y(I)-Y(I-1))/FLOAT(I) RETURN END SUBROUTINE LAPS(Y,X,C,N) DIMENSION C(1) IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1. H1=1.-X T=1.+X DO 4 I=2,N H2=H1-H0+H1-(T*H1-H0)/FLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END 0SUBROUTINE LBVP(PRMT,B,C,R,Y,DERY,NDIM,IHLF,AFCT,FCT,DFCT,OUTP, 1AUX,A) DIMENSION PRMT(1),B(1),C(1),R(1),Y(1),DERY(1),AUX(20,1),A(1) IF(PRMT(3)*(PRMT(2)-PRMT(1)))2,1,3 1 IHLF=12 RETURN 2 IHLF=13 RETURN 3 KK=-NDIM IB=0 IC=0 DO 7 K=1,NDIM AUX(15,K)=DERY(K) AUX(1,K)=1. AUX(17,K)=1. KK=KK+NDIM DO 4 I=1,NDIM II=KK+I IF(B(II))5,4,5 4 CONTINUE IB=IB+1 AUX(1,K)=0. 5 DO 6 I=1,NDIM II=KK+I IF(C(II))7,6,7 6 CONTINUE IC=IC+1 AUX(17,K)=0. 7 CONTINUE IF(IC-IB)8,11,11 8 H=PRMT(2) PRMT(2)=PRMT(1) PRMT(1)=H PRMT(3)=-PRMT(3) DO 9 I=1,NDIM 9 AUX(17,I)=AUX(1,I) II=NDIM*NDIM DO 10 I=1,II H=B(I) B(I)=C(I) 10 C(I)=H 11 X=PRMT(2) CALL FCT(X,Y) CALL DFCT(X,DERY) DO 12 I=1,NDIM AUX(18,I)=Y(I) 12 AUX(19,I)=DERY(I) K=0 KK=0 100 K=K+1 IF(AUX(17,K))108,108,101 101 X=PRMT(2) CALL AFCT(X,A) SUM=0. GL=AUX(18,K) DGL=AUX(19,K) II=K DO 104 I=1,NDIM H=-A(II) DERY(I)=H AUX(20,I)=R(I) Y(I)=0. IF(I-K)103,102,103 102 Y(I)=1. 103 DGL=DGL+H*AUX(18,I) 104 II=II+NDIM XEND=PRMT(1) H=.0625*(XEND-X) ISW=0 GOTO 400 105 IF(IHLF-10)106,106,117 106 DO 107 I=1,NDIM KK=KK+1 H=C(KK) R(I)=AUX(20,I)+H*SUM II=I DO 107 J=1,NDIM B(II)=B(II)+H*Y(J) 107 II=II+NDIM GOTO 109 108 KK=KK+NDIM 109 IF(K-NDIM)100,110,110 110 X=PRMT(4) CALL GELG(R,B,NDIM,1,X,I) IF(I)111,112,112 111 IHLF=14 RETURN 112 PRMT(5)=0. IHLF=-I X=PRMT(1) XEND=PRMT(2) H=PRMT(3) DO 113 I=1,NDIM 113 Y(I)=R(I) ISW=1 114 ISW2=12 GOTO 200 115 ISW3=-1 GOTO 300 116 IF(IHLF)400,400,117 117 RETURN 200 CALL AFCT(X,A) IF(ISW)201,201,205 201 LL=0 DO 203 M=1,NDIM HS=0. DO 202 L=1,NDIM LL=LL+1 202 HS=HS-A(LL)*Y(L) 203 DERY(M)=HS 204 GOTO(502,504,506,407,415,418,608,617,632,634,421,115),ISW2 205 CALL FCT(X,DERY) DO 207 M=1,NDIM LL=M-NDIM HS=0. DO 206 L=1,NDIM LL=LL+NDIM 206 HS=HS+A(LL)*Y(L) 207 DERY(M)=HS+DERY(M) GOTO 204 300 IF(ISW)301,301,305 301 CALL FCT(X,R) GU=0. DGU=0. DO 302 L=1,NDIM GU=GU+Y(L)*R(L) 302 DGU=DGU+DERY(L)*R(L) CALL DFCT(X,R) DO 303 L=1,NDIM 303 DGU=DGU+Y(L)*R(L) SUM=SUM+.5*H*((GL+GU)+.1666667*H*(DGL-DGU)) GL=GU DGL=DGU 304 IF(ISW3)116,422,618 305 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))117,304,117 400 N=1 XST=X IHLF=0 DO 401 I=1,NDIM AUX(16,I)=0. AUX(1,I)=Y(I) 401 AUX(8,I)=DERY(I) ISW1=1 GOTO 500 402 X=X+H DO 403 I=1,NDIM 403 AUX(2,I)=Y(I) 404 IHLF=IHLF+1 X=X-H DO 405 I=1,NDIM 405 AUX(4,I)=AUX(2,I) H=.5*H N=1 ISW1=2 GOTO 500 406 X=X+H ISW2=4 GOTO 200 407 N=2 DO 408 I=1,NDIM AUX(2,I)=Y(I) 408 AUX(9,I)=DERY(I) ISW1=3 GOTO 500 409 DO 414 I=1,NDIM Z=ABS(Y(I)) IF(Z-1.)410,411,411 410 Z=1. 411 DELT=.06666667*ABS(Y(I)-AUX(4,I)) IF(ISW)413,413,412 412 DELT=AUX(15,I)*DELT 413 IF(DELT-Z*PRMT(4))414,414,429 414 CONTINUE X=X+H ISW2=5 GOTO 200 415 DO 416 I=1,NDIM AUX(3,I)=Y(I) 416 AUX(10,I)=DERY(I) N=3 ISW1=4 GOTO 500 417 N=1 X=X+H ISW2=6 GOTO 200 418 X=XST DO 419 I=1,NDIM AUX(11,I)=DERY(I) 4190Y(I)=AUX(1,I)+H*(.375*AUX(8,I)+.7916667*AUX(9,I) 1-.2083333*AUX(10,I)+.04166667*DERY(I)) 420 X=X+H N=N+1 ISW2=11 GOTO 200 421 ISW3=0 GOTO 300 422 IF(N-4)423,600,600 423 DO 424 I=1,NDIM AUX(N,I)=Y(I) 424 AUX(N+7,I)=DERY(I) IF(N-3)425,427,600 425 DO 426 I=1,NDIM DELT=AUX(9,I)+AUX(9,I) DELT=DELT+DELT 426 Y(I)=AUX(1,I)+.3333333*H*(AUX(8,I)+DELT+AUX(10,I)) GOTO 420 427 DO 428 I=1,NDIM DELT=AUX(9,I)+AUX(10,I) DELT=DELT+DELT+DELT 428 Y(I)=AUX(1,I)+.375*H*(AUX(8,I)+DELT+AUX(11,I)) GOTO 420 429 IF(IHLF-10)404,430,430 430 IHLF=11 X=X+H IF(ISW)105,105,114 500 Z=X DO 501 I=1,NDIM X=H*AUX(N+7,I) AUX(5,I)=X 501 Y(I)=AUX(N,I)+.4*X X=Z+.4*H ISW2=1 GOTO 200 502 DO 503 I=1,NDIM X=H*DERY(I) AUX(6,I)=X 503 Y(I)=AUX(N,I)+.2969776*AUX(5,I)+.1587596*X X=Z+.4557372*H ISW2=2 GOTO 200 504 DO 505 I=1,NDIM X=H*DERY(I) AUX(7,I)=X 505 Y(I)=AUX(N,I)+.2181004*AUX(5,I)-3.050965*AUX(6,I)+3.832865*X X=Z+H ISW2=3 GOTO 200 506 DO 507 I=1,NDIM 5070Y(I)=AUX(N,I)+.1747603*AUX(5,I)-.5514807*AUX(6,I) 1+1.205536*AUX(7,I)+.1711848*H*DERY(I) X=Z GOTO(402,406,409,417),ISW1 600 ISTEP=3 601 IF(N-8)604,602,604 602 DO 603 N=2,7 DO 603 I=1,NDIM AUX(N-1,I)=AUX(N,I) 603 AUX(N+6,I)=AUX(N+7,I) N=7 604 N=N+1 DO 605 I=1,NDIM AUX(N-1,I)=Y(I) 605 AUX(N+6,I)=DERY(I) X=X+H 606 ISTEP=ISTEP+1 DO 607 I=1,NDIM 0DELT=AUX(N-4,I)+1.333333*H*(AUX(N+6,I)+AUX(N+6,I)-AUX(N+5,I)+ 1AUX(N+4,I)+AUX(N+4,I)) Y(I)=DELT-.9256198*AUX(16,I) 607 AUX(16,I)=DELT ISW2=7 GOTO 200 608 DO 609 I=1,NDIM 0DELT=.125*(9.*AUX(N-1,I)-AUX(N-3,I)+3.*H*(DERY(I)+AUX(N+6,I)+ 1AUX(N+6,I)-AUX(N+5,I))) AUX(16,I)=AUX(16,I)-DELT 609 Y(I)=DELT+.07438017*AUX(16,I) DELT=0. DO 616 I=1,NDIM Z=ABS(Y(I)) IF(Z-1.)610,611,611 610 Z=1. 611 Z=ABS(AUX(16,I))/Z IF(ISW)613,613,612 612 Z=AUX(15,I)*Z 613 IF(Z-PRMT(4))614,614,628 614 IF(DELT-Z)615,616,616 615 DELT=Z 616 CONTINUE ISW2=8 GOTO 200 617 ISW3=1 GOTO 300 618 IF(H*(X-XEND))619,621,621 619 IF(ABS(X-XEND)-.1*ABS(H))621,620,620 620 IF(DELT-.02*PRMT(4))622,622,601 621 IF(ISW)105,105,117 622 IF(IHLF)601,601,623 623 IF(N-7)601,624,624 624 IF(ISTEP-4)601,625,625 625 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)601,626,601 626 H=H+H IHLF=IHLF-1 ISTEP=0 DO 627 I=1,NDIM AUX(N-1,I)=AUX(N-2,I) AUX(N-2,I)=AUX(N-4,I) AUX(N-3,I)=AUX(N-6,I) AUX(N+6,I)=AUX(N+5,I) AUX(N+5,I)=AUX(N+3,I) AUX(N+4,I)=AUX(N+1,I) DELT=AUX(N+6,I)+AUX(N+5,I) DELT=DELT+DELT+DELT 6270AUX(16,I)=8.962963*(Y(I)-AUX(N-3,I))-3.361111*H*(DERY(I)+DELT 1+AUX(N+4,I)) GOTO 601 628 IHLF=IHLF+1 IF(IHLF-10)630,630,629 629 IF(ISW)105,105,114 630 H=.5*H ISTEP=0 DO 631 I=1,NDIM 0Y(I)=.00390625*(80.*AUX(N-1,I)+135.*AUX(N-2,I)+40.*AUX(N-3,I)+ 1AUX(N-4,I))-.1171875*(AUX(N+6,I)-6.*AUX(N+5,I)-AUX(N+4,I))*H 0AUX(N-4,I)=.00390625*(12.*AUX(N-1,I)+135.*AUX(N-2,I)+ 1108.*AUX(N-3,I)+AUX(N-4,I))-.0234375*(AUX(N+6,I)+18.*AUX(N+5,I)- 29.*AUX(N+4,I))*H AUX(N-3,I)=AUX(N-2,I) 631 AUX(N+4,I)=AUX(N+5,I) DELT=X-H X=DELT-(H+H) ISW2=9 GOTO 200 632 DO 633 I=1,NDIM AUX(N-2,I)=Y(I) AUX(N+5,I)=DERY(I) 633 Y(I)=AUX(N-4,I) X=X-(H+H) ISW2=10 GOTO 200 634 X=DELT DO 635 I=1,NDIM DELT=AUX(N+5,I)+AUX(N+4,I) DELT=DELT+DELT+DELT 0AUX(16,I)=8.962963*(AUX(N-1,I)-Y(I))-3.361111*H*(AUX(N+6,I)+DELT 1+DERY(I)) 635 AUX(N+3,I)=DERY(I) GOTO 606 END SUBROUTINE LEP(Y,X,N) DIMENSION Y(1) Y(1)=1. IF(N)1,1,2 1 RETURN 2 Y(2)=X IF(N-1)1,1,3 3 DO 4 I=2,N G=X*Y(I) 4 Y(I+1)=G-Y(I-1)+G-(G-Y(I-1))/FLOAT(I) RETURN END SUBROUTINE LEPS(Y,X,C,N) DIMENSION C(1) IF(N)1,1,2 1 RETURN 2 Y=C(1) IF(N-2)1,3,3 3 H0=1. H1=X DO 4 I=2,N H2=X*H1 H2=H2-H0+H2-(H2-H0)/FLOAT(I) H0=H1 H1=H2 4 Y=Y+C(I)*H0 RETURN END SUBROUTINE LLSQ(A,B,M,N,L,X,IPIV,EPS,IER,AUX) DIMENSION A(1),B(1),X(1),IPIV(1),AUX(1) IF(M-N)30,1,1 1 PIV=0. IEND=0 DO 4 K=1,N IPIV(K)=K H=0. IST=IEND+1 IEND=IEND+M DO 2 I=IST,IEND 2 H=H+A(I)*A(I) AUX(K)=H IF(H-PIV)4,4,3 3 PIV=H KPIV=K 4 CONTINUE IF(PIV)31,31,5 5 SIG=SQRT(PIV) TOL=SIG*ABS(EPS) LM=L*M IST=-M DO 21 K=1,N IST=IST+M+1 IEND=IST+M-K I=KPIV-K IF(I)8,8,6 6 H=AUX(K) AUX(K)=AUX(KPIV) AUX(KPIV)=H ID=I*M DO 7 I=IST,IEND J=I+ID H=A(I) A(I)=A(J) 7 A(J)=H 8 IF(K-1)11,11,9 9 SIG=0. DO 10 I=IST,IEND 10 SIG=SIG+A(I)*A(I) SIG=SQRT(SIG) IF(SIG-TOL)32,32,11 11 H=A(IST) IF(H)12,13,13 12 SIG=-SIG 13 IPIV(KPIV)=IPIV(K) IPIV(K)=KPIV BETA=H+SIG A(IST)=BETA BETA=1./(SIG*BETA) J=N+K AUX(J)=-SIG IF(K-N)14,19,19 14 PIV=0. ID=0 JST=K+1 KPIV=JST DO 18 J=JST,N ID=ID+M H=0. DO 15 I=IST,IEND II=I+ID 15 H=H+A(I)*A(II) H=BETA*H DO 16 I=IST,IEND II=I+ID 16 A(II)=A(II)-A(I)*H II=IST+ID H=AUX(J)-A(II)*A(II) AUX(J)=H IF(H-PIV)18,18,17 17 PIV=H KPIV=J 18 CONTINUE 19 DO 21 J=K,LM,M H=0. IEND=J+M-K II=IST DO 20 I=J,IEND H=H+A(II)*B(I) 20 II=II+1 H=BETA*H II=IST DO 21 I=J,IEND B(I)=B(I)-A(II)*H 21 II=II+1 IER=0 I=N LN=L*N PIV=1./AUX(2*N) DO 22 K=N,LN,N X(K)=PIV*B(I) 22 I=I+M IF(N-1)26,26,23 23 JST=(N-1)*M+N DO 25 J=2,N JST=JST-M-1 K=N+N+1-J PIV=1./AUX(K) KST=K-N ID=IPIV(KST)-KST IST=2-J DO 25 K=1,L H=B(KST) IST=IST+N IEND=IST+J-2 II=JST DO 24 I=IST,IEND II=II+M 24 H=H-A(II)*X(I) I=IST-1 II=I+ID X(I)=X(II) X(II)=PIV*H 25 KST=KST+M 26 IST=N+1 IEND=0 DO 29 J=1,L IEND=IEND+M H=0. IF(M-N)29,29,27 27 DO 28 I=IST,IEND 28 H=H+B(I)*B(I) IST=IST+M 29 AUX(J)=H RETURN 30 IER=-2 RETURN 31 IER=-1 RETURN 32 IER=K-1 RETURN END SUBROUTINE LOAD (M,K,R,V) DIMENSION R(1),V(1) L=0 JJ=0 DO 160 J=1,K JJ=JJ+J 150 SQ= SQRT(R(JJ)) DO 160 I=1,M L=L+1 160 V(L)=SQ*V(L) RETURN END SUBROUTINE LOC(I,J,IR,N,M,MS) IX=I JX=J IF(MS-1) 10,20,30 10 IRX=N*(JX-1)+IX GO TO 36 20 IF(IX-JX) 22,24,24 22 IRX=IX+(JX*JX-JX)/2 GO TO 36 24 IRX=JX+(IX*IX-IX)/2 GO TO 36 30 IRX=0 IF(IX-JX) 36,32,36 32 IRX=IX 36 IR=IRX RETURN END SUBROUTINE MADD(A,B,R,N,M,MSA,MSB) DIMENSION A(1),B(1),R(1) IF(MSA-MSB) 7,5,7 5 CALL LOC(N,M,NM,N,M,MSA) GO TO 100 7 MTEST=MSA*MSB MSR=0 IF(MTEST) 20,20,10 10 MSR=1 20 IF(MTEST-2) 35,35,30 30 MSR=2 35 DO 90 J=1,M DO 90 I=1,N CALL LOC(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL LOC(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL LOC(I,J,IJB,N,M,MSB) BEL=0.0 IF(IJB) 70,80,70 70 BEL=B(IJB) 80 R(IJR)=AEL+BEL 90 CONTINUE RETURN 100 DO 110 I=1,NM 110 R(I)=A(I)+B(I) RETURN END SUBROUTINE MATA(A,R,N,M,MS) DIMENSION A(1),R(1) DO 60 K=1,M KX=(K*K-K)/2 DO 60 J=1,M IF(J-K) 10,10,60 10 IR=J+KX R(IR)=0 DO 60 I=1,N IF(MS) 20,40,20 20 CALL LOC(I,J,IA,N,M,MS) CALL LOC(I,K,IB,N,M,MS) IF(IA) 30,60,30 30 IF(IB) 50,60,50 40 IA=N*(J-1)+I IB=N*(K-1)+I 50 R(IR)=R(IR)+A(IA)*A(IB) 60 CONTINUE RETURN END SUBROUTINE MCHB(R,A,M,N,MUD,IOP,EPS,IER) DIMENSION R(1),A(1) DOUBLE PRECISION TOL,SUM,PIV IF(IABS(IOP)-3)1,1,43 1 IF(MUD)43,2,2 2 MC=MUD+1 IF(M-MC)43,3,3 3 MR=M-MUD IER=0 IF(IOP)24,4,4 4 IEND=0 LLDST=MUD DO 23 K=1,M IST=IEND+1 IEND=IST+MUD J=K-MR IF(J)6,6,5 5 IEND=IEND-J 6 IF(J-1)8,8,7 7 LLDST=LLDST-1 8 LMAX=MUD J=MC-K IF(J)10,10,9 9 LMAX=LMAX-J 10 ID=0 TOL=A(IST)*EPS DO 23 I=IST,IEND SUM=0.D0 IF(LMAX)14,14,11 11 LL=IST LLD=LLDST DO 13 L=1,LMAX LL=LL-LLD LLL=LL+ID SUM=SUM+A(LL)*A(LLL) IF(LLD-MUD)12,13,13 12 LLD=LLD+1 13 CONTINUE 14 SUM=DBLE(A(I))-SUM IF(I-IST)15,15,20 15 IF(SUM)43,43,16 16 IF(SUM-TOL)17,17,19 17 IF(IER)18,18,19 18 IER=K-1 19 PIV=DSQRT(SUM) A(I)=PIV PIV=1.D0/PIV GO TO 21 20 A(I)=SUM*PIV 21 ID=ID+1 IF(ID-J)23,23,22 22 LMAX=LMAX-1 23 CONTINUE IF(IOP)24,44,24 24 ID=N*M IEND=IABS(IOP)-2 IF(IEND)25,35,25 25 IST=1 LMAX=0 J=-MR LLDST=MUD DO 34 K=1,M PIV=A(IST) IF(PIV)26,43,26 26 PIV=1.D0/PIV DO 30 I=K,ID,M SUM=0.D0 IF(LMAX)30,30,27 27 LL=IST LLL=I LLD=LLDST DO 29 L=1,LMAX LL=LL-LLD LLL=LLL-1 SUM=SUM+A(LL)*R(LLL) IF(LLD-MUD)28,29,29 28 LLD=LLD+1 29 CONTINUE 30 R(I)=PIV*(DBLE(R(I))-SUM) IF(MC-K)32,32,31 31 LMAX=K 32 IST=IST+MC J=J+1 IF(J)34,34,33 33 IST=IST-J LLDST=LLDST-1 34 CONTINUE IF(IEND)35,35,44 35 IST=M+(MUD*(M+M-MC))/2+1 LMAX=0 K=M 36 IEND=IST-1 IST=IEND-LMAX PIV=A(IST) IF(PIV)37,43,37 37 PIV=1.D0/PIV L=IST+1 DO 40 I=K,ID,M SUM=0.D0 IF(LMAX)40,40,38 38 LLL=I DO 39 LL=L,IEND LLL=LLL+1 39 SUM=SUM+A(LL)*R(LLL) 40 R(I)=PIV*(DBLE(R(I))-SUM) IF(K-MR)42,42,41 41 LMAX=LMAX+1 42 K=K-1 IF(K)44,44,36 43 IER=-1 44 RETURN END SUBROUTINE MCPY(A,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) DO 1 I=1,IT 1 R(I)=A(I) RETURN END SUBROUTINE MEANQ (K,LEVEL,X,GMEAN,SUMSQ,NDF,SMEAN,MSTEP,KOUNT, 1 LASTS) DIMENSION LEVEL(1),X(1),SUMSQ(1),NDF(1),SMEAN(1),MSTEP(1), 1 KOUNT(1),LASTS(1) N=LEVEL(1) DO 150 I=2,K 150 N=N*LEVEL(I) LASTS(1)=LEVEL(1) DO 178 I=2,K 178 LASTS(I)=LEVEL(I)+1 NN=1 LL=(2**K)-1 MSTEP(1)=1 DO 180 I=2,K 180 MSTEP(I)=MSTEP(I-1)*2 DO 185 I=1,LL 185 SUMSQ(I)=0.0 DO 190 I=1,K 190 KOUNT(I)=0 200 L=0 DO 260 I=1,K IF(KOUNT(I)-LASTS(I)) 210, 250, 210 210 IF(L) 220, 220, 240 220 KOUNT(I)=KOUNT(I)+1 IF(KOUNT(I)-LEVEL(I)) 230, 230, 250 230 L=L+MSTEP(I) GO TO 260 240 IF(KOUNT(I)-LEVEL(I)) 230, 260, 230 250 KOUNT(I)=0 260 CONTINUE IF(L) 285, 285, 270 270 SUMSQ(L)=SUMSQ(L)+X(NN)*X(NN) NN=NN+1 GO TO 200 285 FN=N GMEAN=X(NN)/FN DO 310 I=2,K 310 MSTEP(I)=0 NN=0 MSTEP(1)=1 320 ND1=1 ND2=1 DO 340 I=1,K IF(MSTEP(I)) 330, 340, 330 330 ND1=ND1*LEVEL(I) ND2=ND2*(LEVEL(I)-1) 340 CONTINUE FN1=N*ND1 FN2=ND2 NN=NN+1 SUMSQ(NN)=SUMSQ(NN)/FN1 NDF(NN)=ND2 SMEAN(NN)=SUMSQ(NN)/FN2 IF(NN-LL) 345, 370, 370 345 DO 360 I=1,K IF(MSTEP(I)) 347, 350, 347 347 MSTEP(I)=0 GO TO 360 350 MSTEP(I)=1 GO TO 320 360 CONTINUE 370 RETURN END SUBROUTINE MFGR(A,M,N,EPS,IRANK,IROW,ICOL) DIMENSION A(1),IROW(1),ICOL(1) IF(M)2,2,1 1 IF(N)2,2,4 2 IRANK=-1 3 RETURN 4 IRANK=0 PIV=0. JJ=0 DO 6 J=1,N ICOL(J)=J DO 6 I=1,M JJ=JJ+1 HOLD=A(JJ) IF(ABS(PIV)-ABS(HOLD))5,6,6 5 PIV=HOLD IR=I IC=J 6 CONTINUE DO 7 I=1,M 7 IROW(I)=I TOL=ABS(EPS*PIV) NM=N*M DO 19 NCOL=M,NM,M 8 IF(ABS(PIV)-TOL)20,20,9 9 IRANK=IRANK+1 JJ=IR-IRANK IF(JJ)12,12,10 10 DO 11 J=IRANK,NM,M I=J+JJ SAVE=A(J) A(J)=A(I) 11 A(I)=SAVE JJ=IROW(IR) IROW(IR)=IROW(IRANK) IROW(IRANK)=JJ 12 JJ=(IC-IRANK)*M IF(JJ)15,15,13 13 KK=NCOL DO 14 J=1,M I=KK+JJ SAVE=A(KK) A(KK)=A(I) KK=KK-1 14 A(I)=SAVE JJ=ICOL(IC) ICOL(IC)=ICOL(IRANK) ICOL(IRANK)=JJ 15 KK=IRANK+1 MM=IRANK-M LL=NCOL+MM IF(MM)16,25,25 16 JJ=LL SAVE=PIV PIV=0. DO 19 J=KK,M JJ=JJ+1 HOLD=A(JJ)/SAVE A(JJ)=HOLD L=J-IRANK IF(IRANK-N)17,19,19 17 II=JJ DO 19 I=KK,N II=II+M MM=II-L A(II)=A(II)-HOLD*A(MM) IF(ABS(A(II))-ABS(PIV))19,19,18 18 PIV=A(II) IR=J IC=I 19 CONTINUE 20 IF(IRANK-1)3,25,21 21 IR=LL DO 24 J=2,IRANK II=J-1 IR=IR-M JJ=LL DO 23 I=KK,M HOLD=0. JJ=JJ+1 MM=JJ IC=IR DO 22 L=1,II HOLD=HOLD+A(MM)*A(IC) IC=IC-1 22 MM=MM-M 23 A(MM)=A(MM)-HOLD 24 CONTINUE 25 IF(N-IRANK)3,3,26 26 IR=LL KK=LL+M DO 30 J=1,IRANK DO 29 I=KK,NM,M JJ=IR LL=I HOLD=0. II=J 27 II=II-1 IF(II)29,29,28 28 HOLD=HOLD-A(JJ)*A(LL) JJ=JJ-M LL=LL-1 GOTO 27 29 A(LL)=(HOLD-A(LL))/A(JJ) 30 IR=IR-1 RETURN END SUBROUTINE MFSD(A,N,EPS,IER) DIMENSION A(1) DOUBLE PRECISION DPIV,DSUM IF(N-1) 12,1,1 1 IER=0 KPIV=0 DO 11 K=1,N KPIV=KPIV+K IND=KPIV LEND=K-1 TOL=ABS(EPS*A(KPIV)) DO 11 I=K,N DSUM=0.D0 IF(LEND) 2,4,2 2 DO 3 L=1,LEND LANF=KPIV-L LIND=IND-L 3 DSUM=DSUM+DBLE(A(LANF)*A(LIND)) 4 DSUM=DBLE(A(IND))-DSUM IF(I-K) 10,5,10 5 IF(SNGL(DSUM)-TOL) 6,6,9 6 IF(DSUM) 12,12,7 7 IF(IER) 8,8,9 8 IER=K-1 9 DPIV=DSQRT(DSUM) A(KPIV)=DPIV DPIV=1.D0/DPIV GO TO 11 10 A(IND)=DSUM*DPIV 11 IND=IND+I RETURN 12 IER=-1 RETURN END SUBROUTINE MFSS(A,N,EPS,IRANK,TRAC) DIMENSION A(1),TRAC(1) DOUBLE PRECISION SUM IF(N)36,36,1 1 IRANK=0 ISUB=0 KPIV=0 J=0 PIV=0. DO 3 K=1,N J=J+K TRAC(K)=A(J) IF(A(J)-PIV)3,3,2 2 PIV=A(J) KSUB=J KPIV=K 3 CONTINUE DO 32 I=1,N ISUB=ISUB+I IM1=I-1 4 KMI=KPIV-I IF(KMI)35,9,5 5 JI=KSUB-KMI IDC=JI-ISUB JJ=ISUB-IM1 DO 6 K=JJ,ISUB KK=K+IDC HOLD=A(K) A(K)=A(KK) 6 A(KK)=HOLD KK=KSUB DO 7 K=KPIV,N II=KK-KMI HOLD=A(KK) A(KK)=A(II) A(II)=HOLD 7 KK=KK+K JJ=KPIV-1 II=ISUB DO 8 K=I,JJ HOLD=A(II) A(II)=A(JI) A(JI)=HOLD II=II+K 8 JI=JI+1 9 IF(IRANK)22,10,10 10 TRAC(KPIV)=TRAC(I) TRAC(I)=KPIV KK=IM1-IRANK KMI=ISUB-KK PIV=0. IDC=IRANK+1 JI=ISUB-1 JK=KMI JJ=ISUB-I DO 19 K=I,N SUM=0.D0 IF(KK)13,13,11 11 DO 12 J=KMI,JI SUM=SUM-A(J)*A(JK) 12 JK=JK+1 13 JJ=JJ+K IF(K-I)14,14,16 14 SUM=A(ISUB)+SUM IF(SUM-ABS(A(ISUB)*EPS))20,20,15 15 A(ISUB)=DSQRT(SUM) KPIV=I+1 GOTO 19 16 SUM=(A(JK)+SUM)/A(ISUB) A(JK)=SUM IF(A(JJ))19,19,17 17 TRAC(K)=TRAC(K)-SUM*SUM HOLD=TRAC(K)/A(JJ) IF(PIV-HOLD)18,19,19 18 PIV=HOLD KPIV=K KSUB=JJ 19 JK=JJ+IDC GOTO 32 20 IF(IRANK)21,21,37 21 IRANK=-1 GOTO 4 22 IRANK=IM1 II=ISUB-IRANK JI=II DO 26 K=1,IRANK JI=JI-1 JK=ISUB-1 JJ=K-1 DO 26 J=I,N IDC=IRANK SUM=0.D0 KMI=JI KK=JK IF(JJ)25,25,23 23 DO 24 L=1,JJ IDC=IDC-1 SUM=SUM-A(KMI)*A(KK) KMI=KMI-IDC 24 KK=KK-1 25 A(KK)=(SUM+A(KK))/A(KMI) 26 JK=JK+J JJ=ISUB-I PIV=0. KK=ISUB-1 DO 31 K=I,N JJ=JJ+K IDC=0 DO 28 J=K,N SUM=0.D0 KMI=JJ+IDC DO 27 L=II,KK JK=L+IDC 27 SUM=SUM+A(L)*A(JK) A(KMI)=SUM 28 IDC=IDC+J A(JJ)=A(JJ)+1.D0 TRAC(K)=A(JJ) IF(PIV-A(JJ))29,30,30 29 KPIV=K KSUB=JJ PIV=A(JJ) 30 II=II+K KK=KK+K 31 CONTINUE GOTO 4 32 CONTINUE 33 IF(IRANK)35,34,35 34 IRANK=N 35 RETURN 36 IRANK=-1 RETURN 37 IRANK=-2 RETURN END SUBROUTINE MFUN(A,F,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) DO 5 I=1,IT 5 R(I)=F(A(I)) RETURN END SUBROUTINE MINV(A,N,D,L,M) DIMENSION A(1),L(1),M(1) D=1.0 NK=-N DO 80 K=1,N NK=NK+N L(K)=K M(K)=K KK=NK+K BIGA=A(KK) DO 20 J=K,N IZ=N*(J-1) DO 20 I=K,N IJ=IZ+I 10 IF( ABS(BIGA)- ABS(A(IJ))) 15,20,20 15 BIGA=A(IJ) L(K)=I M(K)=J 20 CONTINUE J=L(K) IF(J-K) 35,35,25 25 KI=K-N DO 30 I=1,N KI=KI+N HOLD=-A(KI) JI=KI-K+J A(KI)=A(JI) 30 A(JI) =HOLD 35 I=M(K) IF(I-K) 45,45,38 38 JP=N*(I-1) DO 40 J=1,N JK=NK+J JI=JP+J HOLD=-A(JK) A(JK)=A(JI) 40 A(JI) =HOLD 45 IF(BIGA) 48,46,48 46 D=0.0 RETURN 48 DO 55 I=1,N IF(I-K) 50,55,50 50 IK=NK+I A(IK)=A(IK)/(-BIGA) 55 CONTINUE DO 65 I=1,N IK=NK+I HOLD=A(IK) IJ=I-N DO 65 J=1,N IJ=IJ+N IF(I-K) 60,65,60 60 IF(J-K) 62,65,62 62 KJ=IJ-I+K A(IJ)=HOLD*A(KJ)+A(IJ) 65 CONTINUE KJ=K-N DO 75 J=1,N KJ=KJ+N IF(J-K) 70,75,70 70 A(KJ)=A(KJ)/BIGA 75 CONTINUE D=D*BIGA A(KK)=1.0/BIGA 80 CONTINUE K=N 100 K=(K-1) IF(K) 150,150,105 105 I=L(K) IF(I-K) 120,120,108 108 JQ=N*(K-1) JR=N*(I-1) DO 110 J=1,N JK=JQ+J HOLD=A(JK) JI=JR+J A(JK)=-A(JI) 110 A(JI) =HOLD 120 J=M(K) IF(J-K) 100,100,125 125 KI=K-N DO 130 I=1,N KI=KI+N HOLD=A(KI) JI=KI-K+J A(KI)=-A(JI) 130 A(JI) =HOLD GO TO 100 150 RETURN END SUBROUTINE MISR (NO,M,X,CODE,XBAR,STD,SKEW,CURT,R,N,A,B,S,IER) DIMENSION X(1),CODE(1),XBAR(1),STD(1),SKEW(1),CURT(1),R(1),N(1) DIMENSION A(1),B(1),S(1) IER=0 L=0 DO 20 J=1,M FN=0.0 XBAR(J)=0.0 DO 15 I=1,NO L=L+1 IF(X(L)-CODE(J)) 12, 15, 12 12 FN=FN+1.0 XBAR(J)=XBAR(J)+X(L) 15 CONTINUE IF(FN) 16, 16, 17 16 XBAR(J)=0.0 GO TO 20 17 XBAR(J)=XBAR(J)/FN 20 CONTINUE L=0 DO 55 J=1,M LJJ=NO*(J-1) SKEW(J)=0.0 CURT(J)=0.0 KI=M*(J-1) KJ=J-M DO 54 I=1,J KI=KI+1 KJ=KJ+M SUMX=0.0 SUMY=0.0 TI=0.0 TJ=0.0 TII=0.0 TJJ=0.0 TIJ=0.0 NIJ=0 LI=NO*(I-1) LJ=LJJ L=L+1 DO 38 K=1,NO LI=LI+1 LJ=LJ+1 IF(X(LI)-CODE(I)) 30, 38, 30 30 IF(X(LJ)-CODE(J)) 35, 38, 35 35 XX=X(LI)-XBAR(I) YY=X(LJ)-XBAR(J) TI=TI+XX TII=TII+XX**2 TJ=TJ+YY TJJ=TJJ+YY**2 TIJ=TIJ+XX*YY NIJ=NIJ+1 SUMX=SUMX+X(LI) SUMY=SUMY+X(LJ) IF(I-J) 38, 37, 37 37 SKEW(J)=SKEW(J)+YY**3 CURT(J)=CURT(J)+YY**4 38 CONTINUE IF(NIJ) 40, 40, 39 39 FN=NIJ R(L)=TIJ-TI*TJ/FN N(L)=NIJ TII=TII-TI*TI/FN TJJ=TJJ-TJ*TJ/FN 40 IF(I-J) 47, 41, 47 41 IF(NIJ-2) 42,42,43 42 IER=1 R(L)=1.0E33 A(KI)=1.0E33 B(KI)=1.0E33 S(KI)=1.0E33 GO TO 45 43 STD(J)=R(L) R(L)=1.0 A(KI)=0.0 B(KI)=1.0 S(KI)=0.0 IF(STD(J)-(1.0E-20)) 44,44,46 44 IER=2 45 STD(J)=1.0E33 SKEW(J)=1.0E33 CURT(J)=1.0E33 GO TO 55 46 WORK=STD(J)/FN SKEW(J)=(SKEW(J)/FN)/(WORK*SQRT(WORK)) CURT(J)=((CURT(J)/FN)/WORK**2)-3.0 STD(J)=SQRT(STD(J)/(FN-1.0)) GO TO 55 47 IF(NIJ-2) 48,48,50 48 IER=1 49 R(L)=1.0E33 A(KI)=1.0E33 B(KI)=1.0E33 S(KI)=1.0E33 A(KJ)=1.0E33 B(KJ)=1.0E33 S(KJ)=1.0E33 GO TO 54 50 IF(TII-(1.0E-20)) 52,52,51 51 IF(TJJ-(1.0E-20)) 52,52,53 52 IER=2 GO TO 49 53 SUMX=SUMX/FN SUMY=SUMY/FN B(KI)=R(L)/TII A(KI)=SUMY-B(KI)*SUMX B(KJ)=R(L)/TJJ A(KJ)=SUMX-B(KJ)*SUMY R(L)=R(L)/(SQRT(TII)*SQRT(TJJ)) RR=R(L)**2 SUMX=(TJJ-TJJ*RR)/(FN-2) S(KI)=SQRT(SUMX/TII) SUMY=(TII-TII*RR)/(FN-2) S(KJ)=SQRT(SUMY/TJJ) 54 CONTINUE 55 CONTINUE RETURN END SUBROUTINE MLSS(A,N,IRANK,TRAC,INC,RHS,IER) DIMENSION A(1),TRAC(1),RHS(1) DOUBLE PRECISION SUM IDEF=N-IRANK IF(N)33,33,1 1 IF(IRANK)33,33,2 2 IF(IDEF)33,3,3 3 ITE=IRANK*(IRANK+1)/2 IX2=IRANK+1 NP1=N+1 IER=0 JJ=1 II=1 4 DO 6 I=1,N J=TRAC(II) IF(J)31,31,5 5 HOLD=RHS(II) RHS(II)=RHS(J) RHS(J)=HOLD 6 II=II+JJ IF(JJ)32,7,7 7 ISW=1 IF(INC*IDEF)8,28,8 8 ISTA=ITE DO 10 I=1,IRANK ISTA=ISTA+1 JJ=ISTA SUM=0.D0 DO 9 J=IX2,N SUM=SUM+A(JJ)*RHS(J) 9 JJ=JJ+J 10 RHS(I)=RHS(I)+SUM GOTO(11,28,11),ISW 11 ISTA=ITE DO 15 I=IX2,N JJ=ISTA SUM=0.D0 DO 12 J=1,IRANK JJ=JJ+1 12 SUM=SUM+A(JJ)*RHS(J) GOTO(13,13,14),ISW 13 SUM=-SUM 14 RHS(I)=SUM 15 ISTA=ISTA+I GOTO(16,29,30),ISW 16 ISTA=IX2 IEND=N JJ=ITE+ISTA 17 SUM=0.D0 DO 20 I=ISTA,IEND IF(A(JJ))18,31,18 18 RHS(I)=(RHS(I)-SUM)/A(JJ) IF(I-IEND)19,21,21 19 JJ=JJ+ISTA SUM=0.D0 DO 20 J=ISTA,I SUM=SUM+A(JJ)*RHS(J) 20 JJ=JJ+1 21 SUM=0.D0 II=IEND DO 24 I=ISTA,IEND RHS(II)=(RHS(II)-SUM)/A(JJ) IF(II-ISTA)25,25,22 22 KK=JJ-1 SUM=0.D0 DO 23 J=II,IEND SUM=SUM+A(KK)*RHS(J) 23 KK=KK+J JJ=JJ-II 24 II=II-1 25 IF(IDEF)26,30,26 26 GOTO(27,11,8),ISW 27 ISW=2 GOTO 8 28 ISTA=1 IEND=IRANK JJ=1 ISW=2 GOTO 17 29 ISW=3 GOTO 16 30 II=N JJ=-1 GOTO 4 31 IER=1 32 RETURN 33 IER=-1 RETURN END SUBROUTINE MOMEN (F,UBO,NOP,ANS) DIMENSION F(1),UBO(1),ANS(1) DO 100 I=1,4 100 ANS(I)=0.0 N=(UBO(3)-UBO(1))/UBO(2)+0.5 T=0.0 DO 110 I=1,N 110 T=T+F(I) IF(NOP-5) 130, 120, 115 115 NOP=5 120 JUMP=1 GO TO 150 130 JUMP=2 150 DO 160 I=1,N FI=I 160 ANS(1)=ANS(1)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)) ANS(1)=ANS(1)/T GO TO (350,200,250,300,200), NOP 200 DO 210 I=1,N FI=I 210 ANS(2)=ANS(2)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**2 ANS(2)=ANS(2)/T GO TO (250,350), JUMP 250 DO 260 I=1,N FI=I 260 ANS(3)=ANS(3)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**3 ANS(3)=ANS(3)/T GO TO (300,350), JUMP 300 DO 310 I=1,N FI=I 310 ANS(4)=ANS(4)+F(I)*(UBO(1)+(FI-0.5)*UBO(2)-ANS(1))**4 ANS(4)=ANS(4)/T 350 RETURN END SUBROUTINE MPAIR (N,A,B,K,T,Z,P,D,E,L,IE) DIMENSION A(1),B(1),D(1),E(1),L(1) IE=0 K=N BIG=0.0 DO 55 I=1,N DIF=A(I)-B(I) IF(DIF) 10, 20, 30 10 L(I)=1 GO TO 40 20 L(I)=2 K=K-1 GO TO 40 30 L(I)=3 40 DIF= ABS(DIF) IF(BIG-DIF) 45, 50, 50 45 BIG=DIF 50 D(I)=DIF 55 CONTINUE IF(K) 57,57,59 57 IE=1 T=0.0 Z=-1.0E33 P=0 GO TO 100 59 BIG=BIG*2.0 DO 65 I=1,N IF(L(I)-2) 65, 60, 65 60 D(I)=BIG 65 CONTINUE CALL RANK (D,E,N) SUMP=0.0 SUMM=0.0 DO 80 I=1,N IF(L(I)-2) 70, 80, 75 70 SUMM=SUMM+E(I) GO TO 80 75 SUMP=SUMP+E(I) 80 CONTINUE IF(SUMP-SUMM) 85, 85, 90 85 T=SUMP GO TO 95 90 T=SUMM 95 FK=K U=FK*(FK+1.0)/4.0 S= SQRT((FK*(FK+1.0)*(2.0*FK+1.0))/24.0) Z=(T-U)/S CALL NDTR (Z,P,BIG) 100 RETURN END SUBROUTINE MPRC(A,M,N,ITRA,INV,IROCO,IER) DIMENSION A(1),ITRA(1) IF(M)14,14,1 1 IF(N)14,14,2 2 IF(IROCO)3,4,3 3 MM=M MMM=-1 L=M LL=N GO TO 5 4 MM=1 MMM=M L=N LL=M 5 IA=1 ID=1 IF(INV)6,7,6 6 IA=LL ID=-1 7 DO 12 I=1,LL K=ITRA(IA) IF(K-IA)8,12,9 8 IF(K)13,13,10 9 IF(LL-K)13,10,10 10 IL=IA*MM K=K*MM DO 11 J=1,L SAVE=A(IL) A(IL)=A(K) A(K)=SAVE K=K+MMM 11 IL=IL+MMM 12 IA=IA+ID IER=0 RETURN 13 IER=1 RETURN 14 IER=-1 RETURN END SUBROUTINE MPRD(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) MS=MSA*10+MSB IF(MS-22) 30,10,30 10 DO 20 I=1,N 20 R(I)=A(I)*B(I) RETURN 30 IR=1 DO 90 K=1,L DO 90 J=1,N R(IR)=0 DO 80 I=1,M IF(MS) 40,60,40 40 CALL LOC(J,I,IA,N,M,MSA) CALL LOC(I,K,IB,M,L,MSB) IF(IA) 50,80,50 50 IF(IB) 70,80,70 60 IA=N*(I-1)+J IB=M*(K-1)+I 70 R(IR)=R(IR)+A(IA)*B(IB) 80 CONTINUE 90 IR=IR+1 RETURN END SUBROUTINE MSTR(A,R,N,MSA,MSR) DIMENSION A(1),R(1) DO 20 I=1,N DO 20 J=1,N IF(MSR) 5,10,5 5 IF(I-J) 10,10,20 10 CALL LOC(I,J,IR,N,N,MSR) IF(IR) 20,20,15 15 R(IR)=0.0 CALL LOC(I,J,IA,N,N,MSA) IF(IA) 20,20,18 18 R(IR)=A(IA) 20 CONTINUE RETURN END SUBROUTINE MSUB(A,B,R,N,M,MSA,MSB) DIMENSION A(1),B(1),R(1) IF(MSA-MSB) 7,5,7 5 CALL LOC(N,M,NM,N,M,MSA) GO TO 100 7 MTEST=MSA*MSB MSR=0 IF(MTEST) 20,20,10 10 MSR=1 20 IF(MTEST-2) 35,35,30 30 MSR=2 35 DO 90 J=1,M DO 90 I=1,N CALL LOC(I,J,IJR,N,M,MSR) IF(IJR) 40,90,40 40 CALL LOC(I,J,IJA,N,M,MSA) AEL=0.0 IF(IJA) 50,60,50 50 AEL=A(IJA) 60 CALL LOC(I,J,IJB,N,M,MSB) BEL=0.0 IF(IJB) 70,80,70 70 BEL=B(IJB) 80 R(IJR)=AEL-BEL 90 CONTINUE RETURN 100 DO 110 I=1,NM 110 R(I)=A(I)-B(I) RETURN END SUBROUTINE MTDS(A,M,N,T,IOP,IER) DIMENSION A(1),T(1) DOUBLE PRECISION DSUM IF(M)2,2,1 1 IF(N)2,2,4 2 IER=-1 RETURN 3 IER=1 RETURN 4 MN=M*N MM=M*(M+1)/2 MM1=M-1 IER=0 ICS=M IRS=1 IMEND=M IF(IOP)5,2,6 5 MM=N*(N+1)/2 MM1=N-1 IRS=M ICS=1 IMEND=MN-M+1 MN=M 6 IOPE=MOD(IOP+3,3) IF(IABS(IOP)-3)7,7,2 7 IF(IOPE-1)8,18,8 8 MEND=1 LLD=IRS MSTA=1 MDEL=1 MX=1 LD=1 LX=0 9 IF(T(MSTA))10,3,10 10 DO 11 I=MEND,MN,ICS 11 A(I)=A(I)/DBLE(T(MSTA)) IF(MM1)2,15,12 12 DO 14 J=1,MM1 MSTA=MSTA+MDEL MDEL=MDEL+MX DO 14 I=MEND,MN,ICS DSUM=0.D0 L=MSTA LDX=LD LL=I DO 13 K=1,J DSUM=DSUM-T(L)*A(LL) LL=LL+LLD L=L+LDX 13 LDX=LDX+LX IF(T(L))14,3,14 14 A(LL)=(DSUM+A(LL))/T(L) 15 IF(IER)16,17,16 16 IER=0 RETURN 17 IF(IOPE)18,18,16 18 IER=1 MEND=IMEND MN=M*N LLD=-IRS MSTA=MM MDEL=-1 MX=0 LD=-MM1 LX=1 GOTO 9 END SUBROUTINE MTRA(A,R,N,M,MS) DIMENSION A(1),R(1) IF(MS) 10,20,10 10 CALL MCPY(A,R,N,N,MS) RETURN 20 IR=0 DO 30 I=1,N IJ=I-N DO 30 J=1,M IJ=IJ+N IR=IR+1 30 R(IR)=A(IJ) RETURN END SUBROUTINE MULTR (N,K,XBAR,STD,D,RX,RY,ISAVE,B,SB,T,ANS) DIMENSION XBAR(1),STD(1),D(1),RX(1),RY(1),ISAVE(1),B(1),SB(1), 1 T(1),ANS(1) MM=K+1 DO 100 J=1,K 100 B(J)=0.0 DO 110 J=1,K L1=K*(J-1) DO 110 I=1,K L=L1+I 110 B(J)=B(J)+RY(I)*RX(L) RM=0.0 BO=0.0 L1=ISAVE(MM) DO 120 I=1,K RM=RM+B(I)*RY(I) L=ISAVE(I) B(I)=B(I)*(STD(L1)/STD(L)) 120 BO=BO+B(I)*XBAR(L) BO=XBAR(L1)-BO SSAR=RM*D(L1) 122 RM= SQRT( ABS(RM)) SSDR=D(L1)-SSAR FN=N-K-1 SY=SSDR/FN DO 130 J=1,K L1=K*(J-1)+J L=ISAVE(J) 125 SB(J)= SQRT( ABS((RX(L1)/D(L))*SY)) 130 T(J)=B(J)/SB(J) 135 SY= SQRT( ABS(SY)) FK=K SSARM=SSAR/FK SSDRM=SSDR/FN F=SSARM/SSDRM ANS(1)=BO ANS(2)=RM ANS(3)=SY ANS(4)=SSAR ANS(5)=FK ANS(6)=SSARM ANS(7)=SSDR ANS(8)=FN ANS(9)=SSDRM ANS(10)=F RETURN END SUBROUTINE NDTR(X,P,D) AX=ABS(X) T=1.0/(1.0+.2316419*AX) D=0.3989423*EXP(-X*X/2.0) P = 1.0 - D*T*((((1.330274*T - 1.821256)*T + 1.781478)*T - 1 0.3565638)*T + 0.3193815) IF(X)1,2,2 1 P=1.0-P 2 RETURN END SUBROUTINE NROOT (M,A,B,XL,X) DIMENSION A(1),B(1),XL(1),X(1) K=1 DO 100 J=2,M L=M*(J-1) DO 100 I=1,J L=L+1 K=K+1 100 B(K)=B(L) MV=0 CALL EIGEN (B,X,M,MV) L=0 DO 110 J=1,M L=L+J 110 XL(J)=1.0/ SQRT( ABS(B(L))) K=0 DO 115 J=1,M DO 115 I=1,M K=K+1 115 B(K)=X(K)*XL(J) DO 120 I=1,M N2=0 DO 120 J=1,M N1=M*(I-1) L=M*(J-1)+I X(L)=0.0 DO 120 K=1,M N1=N1+1 N2=N2+1 120 X(L)=X(L)+B(N1)*A(N2) L=0 DO 130 J=1,M DO 130 I=1,J N1=I-M N2=M*(J-1) L=L+1 A(L)=0.0 DO 130 K=1,M N1=N1+M N2=N2+1 130 A(L)=A(L)+X(N1)*B(N2) CALL EIGEN (A,X,M,MV) L=0 DO 140 I=1,M L=L+I 140 XL(I)=A(L) DO 150 I=1,M N2=0 DO 150 J=1,M N1=I-M L=M*(J-1)+I A(L)=0.0 DO 150 K=1,M N1=N1+M N2=N2+1 150 A(L)=A(L)+B(N1)*X(N2) L=0 K=0 DO 180 J=1,M SUMV=0.0 DO 170 I=1,M L=L+1 170 SUMV=SUMV+A(L)*A(L) 175 SUMV= SQRT(SUMV) DO 180 I=1,M K=K+1 180 X(K)=A(K)/SUMV RETURN END SUBROUTINE NDTRI(P,X,D,IE) IE=0 X=.99999E+33 D=X IF(P)1,4,2 1 IE=-1 GO TO 12 2 IF (P-1.0)7,5,1 4 X=-.999999E+33 5 D=0.0 GO TO 12 7 D=P IF(D-0.5)9,9,8 8 D=1.0-D 9 T2=ALOG(1.0/(D*D)) T=SQRT(T2) X=T-(2.515517+0.802853*T+0.010328*T2)/(1.0+1.432788*T+0.189269*T2 1 +0.001308*T*T2) IF(P-0.5)10,10,11 10 X=-X 11 D=0.3989423*EXP(-X*X/2.0) 12 RETURN END SUBROUTINE ORDER (M,R,NDEP,K,ISAVE,RX,RY) DIMENSION R(1),ISAVE(1),RX(1),RY(1) MM=0 DO 130 J=1,K L2=ISAVE(J) IF(NDEP-L2) 122, 123, 123 122 L=NDEP+(L2*L2-L2)/2 GO TO 125 123 L=L2+(NDEP*NDEP-NDEP)/2 125 RY(J)=R(L) DO 130 I=1,K L1=ISAVE(I) IF(L1-L2) 127, 128, 128 127 L=L1+(L2*L2-L2)/2 GO TO 129 128 L=L2+(L1*L1-L1)/2 129 MM=MM+1 130 RX(MM)=R(L) ISAVE(K+1)=NDEP RETURN END SUBROUTINE PADD(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) NDIM=IDIMX IF (IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF(NDIM) 90,90,30 30 DO 80 I=1,NDIM IF(I-IDIMX) 40,40,60 40 IF(I-IDIMY) 50,50,70 50 Z(I)=X(I)+Y(I) GO TO 80 60 Z(I)=Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END SUBROUTINE PCLA (Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) IDIMY=IDIMX IF(IDIMX) 30,30,10 10 DO 20 I=1,IDIMX 20 Y(I)=X(I) 30 RETURN END SUBROUTINE PCLD (X,IDIMX,U) DIMENSION X(1) K=1 1 J=IDIMX 2 IF (J-K) 4,4,3 3 X(J-1)=X(J-1)+U*X(J) J=J-1 GO TO 2 4 K=K+1 IF (IDIMX-K) 5,5,1 5 RETURN END SUBROUTINE PADDM(Z,IDIMZ,X,IDIMX,FACT,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) NDIM=IDIMX IF(IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF(NDIM) 90,90,30 30 DO 80 I=1,NDIM IF(I-IDIMX) 40,40,60 40 IF(I-IDIMY) 50,50,70 50 Z(I)=FACT*Y(I)+X(I) GO TO 80 60 Z(I)=FACT*Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END SUBROUTINE PDER(Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) IF (IDIMX-1) 3,3,1 1 IDIMY=IDIMX-1 EXPT=0. DO 2 I=1,IDIMY EXPT=EXPT+1. 2 Y(I)=X(I+1)*EXPT GO TO 4 3 IDIMY=0 4 RETURN END SUBROUTINE PDIV(P,IDIMP,X,IDIMX,Y,IDIMY,TOL,IER) DIMENSION P(1),X(1),Y(1) CALL PNORM (Y,IDIMY,TOL) IF(IDIMY) 50,50,10 10 IDIMP=IDIMX-IDIMY+1 IF(IDIMP) 20,30,60 20 IDIMP=0 30 IER=0 40 RETURN 50 IER=1 GO TO 40 60 IDIMX=IDIMY-1 I=IDIMP 70 II=I+IDIMX P(I)=X(II)/Y(IDIMY) DO 80 K=1,IDIMX J=K-1+I X(J)=X(J)-P(I)*Y(K) 80 CONTINUE I=I-1 IF(I) 90,90,70 90 CALL PNORM(X,IDIMX,TOL) GO TO 30 END SUBROUTINE PECN(P,N,BOUND,EPS,TOL,WORK) DIMENSION P(1),WORK(1) FL=BOUND*BOUND 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(P(1))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(P(1)) 5 RETURN 6 NEND=N-2 WORK(N)=-P(N) DO 7 J=1,NEND,2 K=N-J FN=(NEND-1+K)*(NEND+3-K) FK=K*(K-1) 7 WORK(K-1)=-WORK(K+1)*FK*FL/FN IF(K-2)8,8,9 8 FN=ABS(WORK(1)) GOTO 10 9 FN=N-1 FN=ABS(WORK(2)/FN) 10 IF(EPS+FN-TOL)11,11,5 11 EPS=EPS+FN N=N-1 DO 12 J=K,N,2 12 P(J-1)=P(J-1)+WORK(J-1) GOTO 1 END SUBROUTINE PECS(P,N,BOUND,EPS,TOL,WORK) DIMENSION P(1),WORK(1) FL=BOUND*0.5 1 IF(N-1)2,3,6 2 RETURN 3 IF(EPS+ABS(P(1))-TOL)4,4,5 4 N=0 EPS=EPS+ABS(P(1)) 5 RETURN 6 NEND=N-1 WORK(N)=-P(N) DO 7 J=1,NEND K=N-J FN=(NEND-1+K)*(N-K) FK=K*(K+K-1) 7 WORK(K)=-WORK(K+1)*FK*FL/FN FN=ABS(WORK(1)) IF(EPS+FN-TOL)8,8,5 8 EPS=EPS+FN N=NEND DO 9 J=1,NEND 9 P(J)=P(J)+WORK(J) GOTO 1 END SUBROUTINE PERM(IP1,IP2,N,IPAR,IER) DIMENSION IP1(1),IP2(1) IF(N)19,19,1 1 IF(IPAR)2,13,2 2 DO 3 I=1,N 3 IP2(I)=0 DO 6 I=1,N K=IP1(I) IF(K-N)4,5,20 4 IF(K)20,20,5 5 IF(IP2(K))20,6,20 6 IP2(K)=I IF(IPAR)12,7,7 7 DO 8 I=1,N 8 IP2(I)=IP1(I) NN=N-1 IF(NN)12,12,9 9 DO 11 I=1,NN DO 10 J=1,NN IF(IP2(J)-I)10,11,10 10 CONTINUE J=N 11 IP2(J)=IP2(I) 12 IER=0 RETURN 13 DO 14 I=1,N 14 IP2(I)=I DO 18 I=1,N K=IP1(I) IF(K-I)15,18,16 15 IF(K)20,20,17 16 IF(N-K)20,17,17 17 J=IP2(I) IP2(I)=IP2(K) IP2(K)=J 18 CONTINUE GO TO 12 19 IER=-1 RETURN 20 IER=1 RETURN END SUBROUTINE PGCD(X,IDIMX,Y,IDIMY,WORK,EPS,IER) DIMENSION X(1),Y(1),WORK(1) 1 CALL PDIV(WORK,NDIM,X,IDIMX,Y,IDIMY,EPS,IER) IF(IER) 5,2,5 2 IF(IDIMX) 5,5,3 3 DO 4 J=1,IDIMY WORK(1)=X(J) X(J)=Y(J) 4 Y(J)=WORK(1) NDIM=IDIMX IDIMX=IDIMY IDIMY=NDIM GO TO 1 5 RETURN END SUBROUTINE PHI (N,U,V,HU,HV,P,CH,XP,IE) DIMENSION U(1),V(1) IE=0 A=0.0 B=0.0 C=0.0 D=0.0 DO 40 I=1,N IF(U(I)-HU) 10,25,25 10 IF(V(I)-HV) 15,20,20 15 D=D+1.0 GO TO 40 20 B=B+1.0 GO TO 40 25 IF(V(I)-HV) 30,35,35 30 C=C+1.0 GO TO 40 35 A=A+1.0 40 CONTINUE IF(A) 100,100,41 41 IF(B) 100,100,42 42 IF(C) 100,100,43 43 IF(D) 100,100,44 44 P=(A*D-B*C)/ SQRT((A+B)*(C+D)*(A+C)*(B+D)) T=N CH=T*P*P P1=(A+C)/T P2=(B+D)/T P3=(A+B)/T P4=(C+D)/T IF(P1-P2) 75, 45, 45 45 IF(P3-P4) 65, 50, 50 50 IF(P1-P3) 60, 55, 55 55 XP=SQRT((P3/P4)*(P2/P1)) GO TO 95 60 XP=SQRT((P1/P2)*(P4/P3)) GO TO 95 65 IF(P1-P4) 70, 55, 55 70 XP=SQRT((P2/P1)*(P3/P4)) GO TO 95 75 IF(P3-P4) 90, 80, 80 80 IF(P2-P3) 60, 85, 85 85 XP=SQRT((P4/P3)*(P1/P2)) GO TO 95 90 IF(P2-P4) 70, 85, 85 95 RETURN 100 IE=1 P=1.E33 CH=1.E33 XP=1.E33 GO TO 95 END SUBROUTINE PILD (POLY,DVAL,ARGUM,X,IDIMX) DIMENSION X(1) P=ARGUM+ARGUM Q=-ARGUM*ARGUM CALL PQSD (DVAL,POLY,P,Q,X,IDIMX) POLY=ARGUM*DVAL+POLY RETURN END SUBROUTINE PINT(Y,IDIMY,X,IDIMX) DIMENSION X(1),Y(1) IDIMY=IDIMX+1 Y(1)=0. IF(IDIMX)1,1,2 1 RETURN 2 EXPT=1. DO 3 I=2,IDIMY Y(I)=X(I-1)/EXPT 3 EXPT=EXPT+1. GO TO 1 END SUBROUTINE POLRT(XCOF,COF,M,ROOTR,ROOTI,IER) DIMENSION XCOF(1),COF(1),ROOTR(1),ROOTI(1) DOUBLE PRECISION XO,YO,X,Y,XPR,YPR,UX,UY,V,YT,XT,U,XT2,YT2,SUMSQ, 1 DX,DY,TEMP,ALPHA IFIT=0 N=M IER=0 IF(XCOF(N+1))10,25,10 10 IF(N) 15,15,32 15 IER=1 20 RETURN 25 IER=4 GO TO 20 30 IER=2 GO TO 20 32 IF(N-36) 35,35,30 35 NX=N NXX=N+1 N2=1 KJ1 = N+1 DO 40 L=1,KJ1 MT=KJ1-L+1 40 COF(MT)=XCOF(L) 45 XO=.00500101 YO=0.01000101 IN=0 50 X=XO XO=-10.0*YO YO=-10.0*X X=XO Y=YO IN=IN+1 GO TO 59 55 IFIT=1 XPR=X YPR=Y 59 ICT=0 60 UX=0.0 UY=0.0 V =0.0 YT=0.0 XT=1.0 U=COF(N+1) IF(U) 65,130,65 65 DO 70 I=1,N L =N-I+1 TEMP=COF(L) XT2=X*XT-Y*YT YT2=X*YT+Y*XT U=U+TEMP*XT2 V=V+TEMP*YT2 FI=I UX=UX+FI*XT*TEMP UY=UY-FI*YT*TEMP XT=XT2 70 YT=YT2 SUMSQ=UX*UX+UY*UY IF(SUMSQ) 75,110,75 75 DX=(V*UY-U*UX)/SUMSQ X=X+DX DY=-(U*UY+V*UX)/SUMSQ Y=Y+DY 78 IF(DABS(DY)+DABS(DX)-1.0D-05) 100,80,80 80 ICT=ICT+1 IF(ICT-500) 60,85,85 85 IF(IFIT)100,90,100 90 IF(IN-5) 50,95,95 95 IER=3 GO TO 20 100 DO 105 L=1,NXX MT=KJ1-L+1 TEMP=XCOF(MT) XCOF(MT)=COF(L) 105 COF(L)=TEMP ITEMP=N N=NX NX=ITEMP IF(IFIT) 120,55,120 110 IF(IFIT) 115,50,115 115 X=XPR Y=YPR 120 IFIT=0 122 IF(DABS(Y)-1.0D-4*DABS(X)) 135,125,125 125 ALPHA=X+X SUMSQ=X*X+Y*Y N=N-2 GO TO 140 130 X=0.0 NX=NX-1 NXX=NXX-1 135 Y=0.0 SUMSQ=0.0 ALPHA=X N=N-1 140 COF(2)=COF(2)+ALPHA*COF(1) 145 DO 150 L=2,N 150 COF(L+1)=COF(L+1)+ALPHA*COF(L)-SUMSQ*COF(L-1) 155 ROOTI(N2)=Y ROOTR(N2)=X N2=N2+1 IF(SUMSQ) 160,165,160 160 Y=-Y SUMSQ=0.0 GO TO 155 165 IF(N) 20,20,45 END SUBROUTINE PMPY(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) IF(IDIMX*IDIMY)10,10,20 10 IDIMZ=0 GO TO 50 20 IDIMZ=IDIMX+IDIMY-1 DO 30 I=1,IDIMZ 30 Z(I)=0. DO 40 I=1,IDIMX DO 40 J=1,IDIMY K=I+J-1 40 Z(K)=X(I)*Y(J)+Z(K) 50 RETURN END SUBROUTINE PNORM(X,IDIMX,EPS) DIMENSION X(1) 1 IF(IDIMX) 4,4,2 2 IF(ABS(X(IDIMX))-EPS) 3,3,4 3 IDIMX=IDIMX-1 GO TO 1 4 RETURN END SUBROUTINE POINT (N,A,B,HI,ANS,IER) DIMENSION A(1),B(1),ANS(1) IER=0 SUM=0.0 SUM2=0.0 DO 10 I=1,N SUM=SUM+A(I) 10 SUM2=SUM2+A(I)*A(I) FN=N ANS(1)=SUM/FN ANS(2)=(SUM2-ANS(1)*SUM)/(FN-1.0) ANS(2)= SQRT(ANS(2)) P=0.0 SUM=0.0 SUM2=0.0 DO 30 I=1,N IF(B(I)-HI) 20, 25, 25 20 SUM2=SUM2+A(I) GO TO 30 25 P=P+1.0 SUM=SUM+A(I) 30 CONTINUE Q=FN-P ANS(3)=P ANS(4)=Q IF (P) 35,35,40 35 IER=-1 GO TO 50 40 ANS(5)=SUM/P IF (Q) 45,45,60 45 IER=1 50 DO 55 I=5,9 55 ANS(I)=1.E33 GO TO 65 60 ANS(6)=SUM2/Q R=((ANS(5)-ANS(1))/ANS(2))* SQRT(P/Q) ANS(7)=R T=R* SQRT((FN-2.0)/(1.0-R*R)) ANS(8)=T ANS(9)=FN-2 65 RETURN END SUBROUTINE PPRCN(IP1,IP2,IP3,N,IPAR,IER) DIMENSION IP1(1),IP2(1),IP3(1) CALL PERM(IP2,IP3,N,-1,IER) IF(IER)7,1,7 1 CALL PERM(IP1,IP3,N,-1,IER) IF(IER)7,2,7 2 IF(IPAR)3,5,5 3 DO 4 I=1,N K=IP3(I) J=IP2(K) 4 IP3(I)=IP1(J) RETURN 5 DO 6 I=1,N K=IP1(I) 6 IP3(I)=IP2(K) 7 RETURN END SUBROUTINE PQFB(C,IC,Q,LIM,IER) DIMENSION C(1),Q(1) IER=0 J=IC+1 1 J=J-1 IF(J-1)40,40,2 2 IF(C(J))3,1,3 3 A=C(J) IF(A-1.)4,6,4 4 DO 5 I=1,J C(I)=C(I)/A CALL OVERFL(N) IF(N-2)40,5,5 5 CONTINUE 6 IF(J-3)41,38,7 7 EPS=1.E-6 EPS1=1.E-3 L=0 LL=0 Q1=Q(1) Q2=Q(2) QQ1=0. QQ2=0. AA=C(1) BB=C(2) CB=ABS(AA) CA=ABS(BB) IF(CB-CA)8,9,10 8 CC=CB+CB CB=CB/CA CA=1. GO TO 11 9 CC=CA+CA CA=1. CB=1. GO TO 11 10 CC=CA+CA CA=CA/CB CB=1. 11 CD=CC*.1 12 A=0. B=A A1=A B1=A I=J QQQ1=Q1 QQQ2=Q2 DQ1=HH DQ2=H 13 H=-Q1*B-Q2*A+C(I) CALL OVERFL(N) IF(N-2)42,14,14 14 B=A A=H I=I-1 IF(I-1)18,15,16 15 H=0. 16 H=-Q1*B1-Q2*A1+H CALL OVERFL(N) IF(N-2)42,17,17 17 C1=B1 B1=A1 A1=H GO TO 13 18 H=CA*ABS(A)+CB*ABS(B) IF(LL)19,19,39 19 L=L+1 IF(ABS(A)-EPS*ABS(C(1)))20,20,21 20 IF(ABS(B)-EPS*ABS(C(2)))39,39,21 21 IF(H-CC)22,22,23 22 AA=A BB=B CC=H QQ1=Q1 QQ2=Q2 23 IF(L-LIM)28,28,24 24 IF(H-CD)43,43,25 25 IF(Q(1))27,26,27 26 IF(Q(2))27,42,27 27 Q(1)=0. Q(2)=0. GO TO 7 28 HH=AMAX1(ABS(A1),ABS(B1),ABS(C1)) IF(HH)42,42,29 29 A1=A1/HH B1=B1/HH C1=C1/HH H=A1*C1-B1*B1 IF(H)30,42,30 30 A=A/HH B=B/HH HH=(B*A1-A*B1)/H H=(A*C1-B*B1)/H Q1=Q1+HH Q2=Q2+H IF(ABS(HH)-EPS*ABS(Q1))31,31,33 31 IF(ABS(H)-EPS*ABS(Q2))32,32,33 32 LL=1 GO TO 12 33 IF(L-1)12,12,34 34 IF(ABS(HH)-EPS1*ABS(Q1))35,35,12 35 IF(ABS(H)-EPS1*ABS(Q2))36,36,12 36 IF(ABS(QQQ1*HH)-ABS(Q1*DQ1))37,44,44 37 IF(ABS(QQQ2*H)-ABS(Q2*DQ2))12,44,44 38 Q(1)=C(1) Q(2)=C(2) Q(3)=0. Q(4)=0. RETURN 39 Q(1)=Q1 Q(2)=Q2 Q(3)=A Q(4)=B RETURN 40 IER=-1 RETURN 41 IER=-2 RETURN 42 IER=-3 GO TO 44 43 IER=1 44 Q(1)=QQ1 Q(2)=QQ2 Q(3)=AA Q(4)=BB RETURN END SUBROUTINE PQSD(A,B,P,Q,X,IDIMX) DIMENSION X(1) A=0. B=0. J=IDIMX 1 IF(J)3,3,2 2 Z=P*A+B B=Q*A+X(J) A=Z J=J-1 GO TO 1 3 RETURN END SUBROUTINE PRBM(C,IC,RR,RC,POL,IR,IER) DIMENSION C(1),RR(1),RC(1),POL(1),Q(4) EPS=1.E-3 LIM=50 IR=IC+1 1 IR=IR-1 IF(IR-1)42,42,2 2 IF(C(IR))3,1,3 3 IER=0 J=IR L=0 A=C(IR) DO 8 I=1,IR IF(L)4,4,7 4 IF(C(I))6,5,6 5 RR(I)=0. RC(I)=0. POL(J)=0. J=J-1 GO TO 8 6 L=1 IST=I J=0 7 J=J+1 C(I)=C(I)/A POL(J)=C(I) CALL OVERFL(N) IF(N-2)42,8,8 8 CONTINUE Q1=0. Q2=0. 9 IF(J-2)33,10,14 10 A=POL(1) RR(IST)=-A RC(IST)=0. IR=IR-1 Q2=0. IF(IR-1)13,13,11 11 DO 12 I=2,IR Q1=Q2 Q2=POL(I+1) 12 POL(I)=A*Q2+Q1 13 POL(IR+1)=A+Q2 GO TO 34 14 DO 22 L=1,10 N=1 15 Q(1)=Q1 Q(2)=Q2 CALL PQFB(POL,J,Q,LIM,I) IF(I)16,24,23 16 IF(Q1)18,17,18 17 IF(Q2)18,21,18 18 GO TO (19,20,19,21),N 19 Q1=-Q1 N=N+1 GO TO 15 20 Q2=-Q2 N=N+1 GO TO 15 21 Q1=1.+Q1 22 Q2=1.-Q2 IER=3 IR=IR-J RETURN 23 IER=1 24 Q1=Q(1) Q2=Q(2) B=0. A=0. I=J 25 H=-Q1*B-Q2*A+POL(I) POL(I)=B B=A A=H I=I-1 IF(I-2)26,26,25 26 POL(2)=B POL(1)=A L=IR-1 IF(J-L)27,27,29 27 DO 28 I=J,L 28 POL(I-1)=POL(I-1)+POL(I)*Q2+POL(I+1)*Q1 29 POL(L)=POL(L)+POL(L+1)*Q2+Q1 POL(IR)=POL(IR)+Q2 H=-.5*Q2 A=H*H-Q1 B=SQRT(ABS(A)) IF(A)30,30,31 30 RR(IST)=H RC(IST)=B IST=IST+1 RR(IST)=H RC(IST)=-B GO TO 32 31 B=H+SIGN(B,H) RR(IST)=Q1/B RC(IST)=0. IST=IST+1 RR(IST)=B RC(IST)=0. 32 IST=IST+1 J=J-2 GO TO 9 33 IR=IR-1 34 A=0. DO 38 I=1,IR Q1=C(I) Q2=POL(I+1) POL(I)=Q2 IF(Q1)35,36,35 35 Q2=(Q1-Q2)/Q1 36 Q2=ABS(Q2) IF(Q2-A)38,38,37 37 A=Q2 38 CONTINUE I=IR+1 POL(I)=1. RR(I)=A RC(I)=0. IF(IER)39,39,41 39 IF(A-EPS)41,41,40 40 IER=-1 41 RETURN 42 IER=2 IR=0 RETURN END SUBROUTINE PROBT (K,X,S,R,LOG,ANS,W1,W2,IER) DIMENSION X(1),S(1),R(1),ANS(1),W1(1),W2(1) IER=0 IF(K-2)5,5,7 5 IER = 1 GO TO 90 7 DO 8 I=1,K IF(X(I))12,8,8 8 CONTINUE IF(LOG-1) 16,10,16 10 DO 15 I=1,K IF(X(I))12,12,14 12 IER=2 GO TO 90 14 X(I)= ALOG10(X(I)) 15 CONTINUE 16 DO 18 I=1,K IF(S(I)-R(I)) 17,18,18 17 IER=4 GO TO 90 18 CONTINUE 20 DO 23 I=1,K IF(S(I))21,21,22 21 IER=3 GO TO 90 22 W1(I)=R(I)/S(I) 23 CONTINUE WN=0.0 XBAR=0.0 SNWY=0.0 SXX=0.0 SXY=0.0 DO 30 I=1,K P=W1(I) IF(P) 30, 30, 24 24 IF(P-1.0) 25, 30, 30 25 WN=WN+1.0 CALL NDTRI (P,Z,D,IER) Z=Z+5.0 XBAR=XBAR+X(I) SNWY=SNWY+Z SXX=SXX+X(I)**2 SXY=SXY+X(I)*Z 30 CONTINUE B=(SXY-(XBAR*SNWY)/WN)/(SXX-(XBAR*XBAR)/WN) XBAR=XBAR/WN SNWY=SNWY/WN A=SNWY-B*XBAR DD=0.0 DO 31 I=1,K 31 W2(I)=A+B*X(I) 33 SNW=0.0 SNWX=0.0 SNWY=0.0 SNWXX=0.0 SNWXY=0.0 DO 50 I=1,K Y=W2(I) D=Y-5.0 CALL NDTR (D,P,Z) Q=1.0-P W=(Z*Z)/(P*Q) IF(Y-5.0) 35, 35, 40 35 WP=(Y-P/Z)+W1(I)/Z GO TO 45 40 WP=(Y+Q/Z)-(1.0-W1(I))/Z 45 WN=W*S(I) SNW=SNW+WN SNWX=SNWX+WN*X(I) SNWY=SNWY+WN*WP SNWXX=SNWXX+WN*X(I)**2 50 SNWXY=SNWXY+WN*X(I)*WP XBAR=SNWX/SNW SXX=SNWXX-(SNWX)*(SNWX)/SNW SXY=SNWXY-(SNWX)*(SNWY)/SNW B=SXY/SXX A=SNWY/SNW-B*XBAR SXX=0.0 DO 60 I=1,K Y=A+B*X(I) D=W2(I)-Y SXX=SXX+D*D 60 W2(I)=Y IF(( ABS(DD-SXX))-(1.0E-7)) 65, 65, 63 63 DD=SXX GO TO 33 65 ANS(1)=A ANS(2)=B ANS(3)=0.0 DO 70 I=1,K Y=W2(I)-5.0 CALL NDTR (Y,P,D) AA=R(I)-S(I)*P DD=S(I)*P*(1.0-P) 70 ANS(3)=ANS(3)+AA*AA/DD ANS(4)=K-2 80 RETURN 90 DO 100 I=1,K W1(I)=0.0 100 W2(I)=0.0 DO 110 I=1,4 110 ANS(I)=0.0 GO TO 80 END SUBROUTINE PRQD(C,IC,Q,E,POL,IR,IER) DIMENSION E(1),Q(1),C(1),POL(1) IER=0 IR=IC EPS=1.E-6 TOL=1.E-3 LIMIT=10*IC KOUNT=0 1 IF(IR-1)79,79,2 2 IF(C(IR))4,3,4 3 IR=IR-1 GOTO 1 4 O=1./C(IR) IEND=IR-1 ISTA=1 NSAV=IR+1 JBEG=1 DO 9 I=1,IR J=NSAV-I IF(C(I))7,5,7 5 GOTO(6,8),JBEG 6 NSAV=NSAV+1 Q(ISTA)=0. E(ISTA)=0. ISTA=ISTA+1 GOTO 9 7 JBEG=2 8 Q(J)=C(I)*O C(I)=Q(J) 9 CONTINUE ESAV=0. Q(ISTA)=0. 10 NSAV=IR EXPT=IR-ISTA E(ISTA)=EXPT DO 11 I=ISTA,IEND EXPT=EXPT-1.0 POL(I+1)=EPS*ABS(Q(I+1))+EPS 11 E(I+1)=Q(I+1)*EXPT IF(ISTA-IEND)12,20,60 12 JEND=IEND-1 DO 19 I=ISTA,JEND IF(I-ISTA)13,16,13 13 IF(ABS(E(I))-POL(I+1))14,14,16 14 NSAV=I DO 15 K=I,JEND IF(ABS(E(K))-POL(K+1))15,15,80 15 CONTINUE GOTO 21 16 DO 19 K=I,IEND E(K+1)=E(K+1)/E(I) Q(K+1)=E(K+1)-Q(K+1) IF(K-I)18,17,18 17 IF(ABS(Q(I+1))-POL(I+1))80,80,19 18 Q(K+1)=Q(K+1)/Q(I+1) POL(K+1)=POL(K+1)/ABS(Q(I+1)) E(K)=Q(K+1)-E(K) 19 CONTINUE 20 Q(IR)=-Q(IR) 21 E(ISTA)=0. NRAN=NSAV-1 22 E(NRAN+1)=0. IF(NRAN-ISTA)24,23,31 23 Q(ISTA+1)=Q(ISTA+1)+EXPT E(ISTA+1)=0. 24 E(ISTA)=ESAV IF(IR-NSAV)60,60,25 25 ISTA=NSAV ESAV=E(ISTA) GOTO 10 26 P=P+EXPT IF(O)27,28,28 27 Q(NRAN)=P Q(NRAN+1)=P E(NRAN)=T E(NRAN+1)=-T GOTO 29 28 Q(NRAN)=P-T Q(NRAN+1)=P+T E(NRAN)=0. 29 NRAN=NRAN-2 GOTO 22 30 Q(NRAN+1)=EXPT+P NRAN=NRAN-1 GOTO 22 31 JBEG=ISTA+1 JEND=NRAN-1 TEPS=EPS TDELT=1.E-2 32 KOUNT=KOUNT+1 P=Q(NRAN+1) R=ABS(E(NRAN)) IF(R-TEPS)30,30,33 33 S=ABS(E(JEND)) IF(S-R)38,38,34 34 IF(R-TDELT)36,35,35 35 P=0. 36 O=P DO 37 J=JBEG,NRAN Q(J)=Q(J)+E(J)-E(J-1)-O IF(ABS(Q(J))-POL(J))81,81,37 37 E(J)=Q(J+1)*E(J)/Q(J) Q(NRAN+1)=-E(NRAN)+Q(NRAN+1)-O GOTO 54 38 P=0.5*(Q(NRAN)+E(NRAN)+Q(NRAN+1)) O=P*P-Q(NRAN)*Q(NRAN+1) T=SQRT(ABS(O)) IF(S-TEPS)26,26,39 39 IF(O)43,40,40 40 IF(P)42,41,41 41 T=-T 42 P=P+T R=S GOTO 34 43 IF(S-TDELT)44,35,35 44 O=Q(JBEG)+E(JBEG)-P IF(ABS(O)-POL(JBEG))81,81,45 45 T=(T/O)**2 U=E(JBEG)*Q(JBEG+1)/(O*(1.+T)) V=O+U KOUNT=KOUNT+2 DO 53 J=JBEG,NRAN O=Q(J+1)+E(J+1)-U-P IF(ABS(V)-POL(J))46,46,49 46 IF(J-NRAN)81,47,81 47 EXPT=EXPT+P IF(ABS(E(JEND))-TOL)48,48,81 48 P=0.5*(V+O-E(JEND)) O=P*P-(V-U)*(O-U*T-O*W*(1.+T)/Q(JEND)) T=SQRT(ABS(O)) GOTO 26 49 IF(ABS(O)-POL(J+1))46,46,50 50 W=U*O/V T=T*(V/O)**2 Q(J)=V+W-E(J-1) U=0. IF(J-NRAN)51,52,52 51 U=Q(J+2)*E(J+1)/(O*(1.+T)) 52 V=O+U-W IF(ABS(Q(J))-POL(J))81,81,53 53 E(J)=W*V*(1.+T)/Q(J) Q(NRAN+1)=V-E(NRAN) 54 EXPT=EXPT+P TEPS=TEPS*1.1 TDELT=TDELT*1.1 IF(KOUNT-LIMIT)32,55,55 55 IER=1 56 IEND=NSAV-NRAN-1 E(ISTA)=ESAV IF(IEND)59,59,57 57 DO 58 I=1,IEND J=ISTA+I K=NRAN+1+I E(J)=E(K) 58 Q(J)=Q(K) 59 IR=ISTA+IEND 60 IR=IR-1 IF(IR)78,78,61 61 DO 62 I=1,IR Q(I)=Q(I+1) 62 E(I)=E(I+1) POL(IR+1)=1. IEND=IR-1 JBEG=1 DO 69 J=1,IR ISTA=IR+1-J O=0. P=Q(ISTA) T=E(ISTA) IF(T)65,63,65 63 DO 64 I=ISTA,IR POL(I)=O-P*POL(I+1) 64 O=POL(I+1) GOTO 69 65 GOTO(66,67),JBEG 66 JBEG=2 POL(ISTA)=0. GOTO 69 67 JBEG=1 U=P*P+T*T P=P+P DO 68 I=ISTA,IEND POL(I)=O-P*POL(I+1)+U*POL(I+2) 68 O=POL(I+1) POL(IR)=O-P 69 CONTINUE IF(IER)78,70,78 70 P=0. DO 75 I=1,IR IF(C(I))72,71,72 71 O=ABS(POL(I)) GOTO 73 72 O=ABS((POL(I)-C(I))/C(I)) 73 IF(P-O)74,75,75 74 P=O 75 CONTINUE IF(P-TOL)77,76,76 76 IER=-1 77 Q(IR+1)=P E(IR+1)=0. 78 RETURN 79 IER=2 IR=0 RETURN 80 IER=4 IR=ISTA GOTO 60 81 IER=3 GOTO 56 END SUBROUTINE PSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY) DIMENSION Z(1),X(1),Y(1) NDIM=IDIMX IF (IDIMX-IDIMY) 10,20,20 10 NDIM=IDIMY 20 IF (NDIM) 90,90,30 30 DO 80 I=1,NDIM IF (I-IDIMX) 40,40,60 40 IF (I-IDIMY) 50,50,70 50 Z(I)=X(I)-Y(I) GO TO 80 60 Z(I)=-Y(I) GO TO 80 70 Z(I)=X(I) 80 CONTINUE 90 IDIMZ=NDIM RETURN END SUBROUTINE PVAL(RES,ARG,X,IDIMX) DIMENSION X(1) RES=0. J=IDIMX 1 IF(J)3,3,2 2 RES=RES*ARG+X(J) J=J-1 GO TO 1 3 RETURN END SUBROUTINE PVSUB(Z,IDIMZ,X,IDIMX,Y,IDIMY,WORK1,WORK2) DIMENSION Z(1),X(1),Y(1),WORK1(1),WORK2(1) IF (IDIMX-1) 1,3,3 1 IDIMZ=0 2 RETURN 3 IDIMZ=1 Z(1)=X(1) IF (IDIMY*IDIMX-IDIMY) 2,2,4 4 IW1=1 WORK1(1)=1. DO 5 I=2,IDIMX CALL PMPY(WORK2,IW2,Y,IDIMY,WORK1,IW1) CALL PCLA(WORK1,IW1,WORK2,IW2) FACT=X(I) CALL PADDM(Z,IDIMR,Z,IDIMZ,FACT,WORK1,IW1) IDIMZ=IDIMR 5 CONTINUE GO TO 2 END SUBROUTINE QATR(XL,XU,EPS,NDIM,FCT,Y,IER,AUX) DIMENSION AUX(1) AUX(1)=.5*(FCT(XL)+FCT(XU)) H=XU-XL IF(NDIM-1)8,8,1 1 IF(H)2,10,2 2 HH=H E=EPS/ABS(H) DELT2=0. P=1. JJ=1 DO 7 I=2,NDIM Y=AUX(1) DELT1=DELT2 HD=HH HH=.5*HH P=.5*P X=XL+HH SM=0. DO 3 J=1,JJ SM=SM+FCT(X) 3 X=X+HD AUX(I)=.5*AUX(I-1)+P*SM Q=1. JI=I-1 DO 4 J=1,JI II=I-J Q=Q+Q Q=Q+Q 4 AUX(II)=AUX(II+1)+(AUX(II+1)-AUX(II))/(Q-1.) DELT2=ABS(Y-AUX(1)) IF(I-5)7,5,5 5 IF(DELT2-E)10,10,6 6 IF(DELT2-DELT1)7,11,11 7 JJ=JJ+JJ 8 IER=2 9 Y=H*AUX(1) RETURN 10 IER=0 GO TO 9 11 IER=1 Y=H*Y RETURN END SUBROUTINE QA10(FCT,Y) X=29.02495 Y=.4458787E-12*FCT(X) X=21.19389 Y=Y+.8798682E-9*FCT(X) X=15.56116 Y=Y+.2172139E-6*FCT(X) X=11.20813 Y=Y+.1560511E-4*FCT(X) X=7.777439 Y=Y+.0004566773*FCT(X) X=5.084908 Y=Y+.006487547*FCT(X) X=3.022513 Y=Y+.04962104*FCT(X) X=1.522944 Y=Y+.2180344*FCT(X) X=.5438675 Y=Y+.5733510*FCT(X) X=.06019206 Y=Y+.9244873*FCT(X) RETURN END SUBROUTINE QA2(FCT,Y) X=2.724745 Y=.1626257*FCT(X) X=.2752551 Y=Y+1.609828*FCT(X) RETURN END SUBROUTINE QA3(FCT,Y) X=5.525344 Y=.009060020*FCT(X) X=1.784493 Y=Y+.3141346*FCT(X) X=.1901635 Y=Y+1.449259*FCT(X) RETURN END SUBROUTINE QA4(FCT,Y) X=8.588636 Y=.0003992081*FCT(X) X=3.926964 Y=Y+.03415597*FCT(X) X=1.339097 Y=Y+.4156047*FCT(X) X=.1453035 Y=Y+1.322294*FCT(X) RETURN END SUBROUTINE QA5(FCT,Y) X=11.80719 Y=.1528087E-4*FCT(X) X=6.414730 Y=Y+.002687291*FCT(X) X=3.085937 Y=Y+.06774879*FCT(X) X=1.074562 Y=Y+.4802772*FCT(X) X=.1175813 Y=Y+1.221725*FCT(X) RETURN END SUBROUTINE QA6(FCT,Y) X=15.12996 Y=.5317103E-6*FCT(X) X=9.124248 Y=Y+.0001714737*FCT(X) X=5.196153 Y=Y+.007810781*FCT(X) X=2.552590 Y=Y+.1032160*FCT(X) X=.8983028 Y=Y+.5209846*FCT(X) X=.09874701 Y=Y+1.140270*FCT(X) RETURN END SUBROUTINE QA7(FCT,Y) X=18.52828 Y=.1725718E-7*FCT(X) X=11.98999 Y=Y+.9432969E-5*FCT(X) X=7.554091 Y=Y+.0007101852*FCT(X) X=4.389793 Y=Y+.01570011*FCT(X) X=2.180592 Y=Y+.1370111*FCT(X) X=.7721379 Y=Y+.5462112*FCT(X) X=.08511544 Y=Y+1.072812*FCT(X) RETURN END SUBROUTINE QA8(FCT,Y) X=21.98427 Y=.5309615E-9*FCT(X) X=14.97262 Y=Y+.4641962E-6*FCT(X) X=10.09332 Y=Y+.5423720E-4*FCT(X) X=6.483145 Y=Y+.001864568*FCT(X) X=3.809476 Y=Y+.02576062*FCT(X) X=1.905114 Y=Y+.1676201*FCT(X) X=.6772491 Y=Y+.5612949*FCT(X) X=.07479188 Y=Y+1.015859*FCT(X) RETURN END SUBROUTINE QA9(FCT,Y) X=25.48598 Y=.1565640E-10*FCT(X) X=18.04651 Y=Y+.2093441E-7*FCT(X) X=12.77183 Y=Y+.3621309E-5*FCT(X) X=8.769757 Y=Y+.0001836225*FCT(X) X=5.694423 Y=Y+.003777045*FCT(X) X=3.369176 Y=Y+.03728008*FCT(X) X=1.692395 Y=Y+.1946035*FCT(X) X=.6032364 Y=Y+.5696146*FCT(X) X=.06670223 Y=Y+.9669914*FCT(X) RETURN END SUBROUTINE QG10(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4869533*B Y=.03333567*(FCT(A+C)+FCT(A-C)) C=.4325317*B Y=Y+.07472567*(FCT(A+C)+FCT(A-C)) C=.3397048*B Y=Y+.1095432*(FCT(A+C)+FCT(A-C)) C=.2166977*B Y=Y+.1346334*(FCT(A+C)+FCT(A-C)) C=.07443717*B Y=B*(Y+.1477621*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE QG2(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL Y=.2886751*B Y=.5*B*(FCT(A+Y)+FCT(A-Y)) RETURN END SUBROUTINE QG3(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL Y=.3872983*B Y=.2777778*(FCT(A+Y)+FCT(A-Y)) Y=B*(Y+.4444444*FCT(A)) RETURN END SUBROUTINE QG4(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4305682*B Y=.1739274*(FCT(A+C)+FCT(A-C)) C=.1699905*B Y=B*(Y+.3260726*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE QG5(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4530899*B Y=.1184634*(FCT(A+C)+FCT(A-C)) C=.2692347*B Y=Y+.2393143*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.2844444*FCT(A)) RETURN END SUBROUTINE QG6(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4662348*B Y=.08566225*(FCT(A+C)+FCT(A-C)) C=.3306047*B Y=Y+.1803808*(FCT(A+C)+FCT(A-C)) C=.1193096*B Y=B*(Y+.2339570*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE QG7(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4745540*B Y=.06474248*(FCT(A+C)+FCT(A-C)) C=.3707656*B Y=Y+.1398527*(FCT(A+C)+FCT(A-C)) C=.2029226*B Y=Y+.1909150*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.2089796*FCT(A)) RETURN END SUBROUTINE QG8(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4801449*B Y=.05061427*(FCT(A+C)+FCT(A-C)) C=.3983332*B Y=Y+.1111905*(FCT(A+C)+FCT(A-C)) C=.2627662*B Y=Y+.1568533*(FCT(A+C)+FCT(A-C)) C=.09171732*B Y=B*(Y+.1813419*(FCT(A+C)+FCT(A-C))) RETURN END SUBROUTINE QG9(XL,XU,FCT,Y) A=.5*(XU+XL) B=XU-XL C=.4840801*B Y=.04063719*(FCT(A+C)+FCT(A-C)) C=.4180156*B Y=Y+.09032408*(FCT(A+C)+FCT(A-C)) C=.3066857*B Y=Y+.1303053*(FCT(A+C)+FCT(A-C)) C=.1621267*B Y=Y+.1561735*(FCT(A+C)+FCT(A-C)) Y=B*(Y+.1651197*FCT(A)) RETURN END SUBROUTINE QHFE(H,Y,DERY,Z,NDIM) DIMENSION Y(1),DERY(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*H HS=.1666667*H DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*((Y(I)+Y(I-1))+HS*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE QHFG(X,Y,DERY,Z,NDIM) DIMENSION X(1),Y(1),DERY(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5*(X(I)-X(I-1)) SUM2=SUM1+SUM2*((Y(I)+Y(I-1))+.3333333*SUM2*(DERY(I-1)-DERY(I))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE QHSE(H,Y,FDY,SDY,Z,NDIM) DIMENSION Y(1),FDY(1),SDY(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*H HF=.2*H HT=.08333333*H DO 2 I=2,NDIM SUM1=SUM2 0SUM2=SUM2+HH*((Y(I-1)+Y(I))+HF*((FDY(I-1)-FDY(I))+ 1 HT*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE QHSG(X,Y,FDY,SDY,Z,NDIM) DIMENSION X(1),Y(1),FDY(1),SDY(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=.5*(X(I)-X(I-1)) 0SUM2=SUM1+SUM2*((Y(I-1)+Y(I))+.4*SUM2*((FDY(I-1)-FDY(I))+ 1 .1666667*SUM2*(SDY(I-1)+SDY(I)))) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE QH10(FCT,Y) X=3.436159 Z=-X Y=.7640433E-5*(FCT(X)+FCT(Z)) X=2.532732 Z=-X Y=Y+.001343646*(FCT(X)+FCT(Z)) X=1.756684 Z=-X Y=Y+.03387439*(FCT(X)+FCT(Z)) X=1.036611 Z=-X Y=Y+.2401386*(FCT(X)+FCT(Z)) X=.3429013 Z=-X Y=Y+.6108626*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE QH2(FCT,Y) X=.7071068 Z=-X Y=.8862269*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE QH3(FCT,Y) X=1.224745 Z=-X Y=.2954090*(FCT(X)+FCT(Z)) X=0. Y=Y+1.181636*FCT(X) RETURN END SUBROUTINE QH4(FCT,Y) X=1.650680 Z=-X Y=.08131284*(FCT(X)+FCT(Z)) X=.5246476 Z=-X Y=Y+.8049141*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE QH5(FCT,Y) X=2.020183 Z=-X Y=.01995324*(FCT(X)+FCT(Z)) X=.9585725 Z=-X Y=Y+.3936193*(FCT(X)+FCT(Z)) X=0. Y=Y+.9453087*FCT(X) RETURN END SUBROUTINE QH6(FCT,Y) X=2.350605 Z=-X Y=.004530010*(FCT(X)+FCT(Z)) X=1.335849 Z=-X Y=Y+.1570673*(FCT(X)+FCT(Z)) X=.4360774 Z=-X Y=Y+.7246296*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE QH7(FCT,Y) X=2.651961 Z=-X Y=.0009717812*(FCT(X)+FCT(Z)) X=1.673552 Z=-X Y=Y+.05451558*(FCT(X)+FCT(Z)) X=.8162879 Z=-X Y=Y+.4256073*(FCT(X)+FCT(Z)) X=0. Y=Y+.8102646*FCT(X) RETURN END SUBROUTINE QH8(FCT,Y) X=2.930637 Z=-X Y=.0001996041*(FCT(X)+FCT(Z)) X=1.981657 Z=-X Y=Y+.01707798*(FCT(X)+FCT(Z)) X=1.157194 Z=-X Y=Y+.2078023*(FCT(X)+FCT(Z)) X=.3811870 Z=-X Y=Y+.6611470*(FCT(X)+FCT(Z)) RETURN END SUBROUTINE QH9(FCT,Y) X=3.190993 Z=-X Y=.3960698E-4*(FCT(X)+FCT(Z)) X=2.266581 Z=-X Y=Y+.004943624*(FCT(X)+FCT(Z)) X=1.468553 Z=-X Y=Y+.08847453*(FCT(X)+FCT(Z)) X=.7235510 Z=-X Y=Y+.4326516*(FCT(X)+FCT(Z)) X=0. Y=Y+.7202352*FCT(X) RETURN END SUBROUTINE QL10(FCT,Y) X=29.92070 Y=.9911827E-12*FCT(X) X=21.99659 Y=Y+.1839565E-8*FCT(X) X=16.27926 Y=Y+.4249314E-6*FCT(X) X=11.84379 Y=Y+.2825923E-4*FCT(X) X=8.330153 Y=Y+.7530084E-3*FCT(X) X=5.552496 Y=Y+.009501517*FCT(X) X=3.401434 Y=Y+.06208746*FCT(X) X=1.808343 Y=Y+.2180683*FCT(X) X=.7294545 Y=Y+.4011199*FCT(X) X=.1377935 Y=Y+.3084411*FCT(X) RETURN END SUBROUTINE QL2(FCT,Y) X=3.414214 Y=.1464466*FCT(X) X=.5857864 Y=Y+.8535534*FCT(X) RETURN END SUBROUTINE QL3(FCT,Y) X=6.289945 Y=.01038926*FCT(X) X=2.294280 Y=Y+.2785177*FCT(X) X=.4157746 Y=Y+.7110930*FCT(X) RETURN END SUBROUTINE QL4(FCT,Y) X=9.395071 Y=.5392947E-3*FCT(X) X=4.536620 Y=Y+.03888791*FCT(X) X=1.745761 Y=Y+.3574187*FCT(X) X=.3225477 Y=Y+.6031541*FCT(X) RETURN END SUBROUTINE QL5(FCT,Y) X=12.64080 Y=.2336997E-4*FCT(X) X=7.085810 Y=Y+.3611759E-2*FCT(X) X=3.596426 Y=Y+.07594245*FCT(X) X=1.413403 Y=Y+.3986668*FCT(X) X=.2635603 Y=Y+.5217556*FCT(X) RETURN END SUBROUTINE QL6(FCT,Y) X=15.98287 Y=.8985479E-6*FCT(X) X=9.837467 Y=Y+.2610172E-3*FCT(X) X=5.775144 Y=Y+.01039920*FCT(X) X=2.992736 Y=Y+.1133734*FCT(X) X=1.188932 Y=Y+.4170008*FCT(X) X=.2228466 Y=Y+.4589647*FCT(X) RETURN END SUBROUTINE QL7(FCT,Y) X=19.39573 Y=.3170315E-7*FCT(X) X=12.73418 Y=Y+.1586546E-4*FCT(X) X=8.182153 Y=Y+.1074010E-2*FCT(X) X=4.900353 Y=Y+.02063351*FCT(X) X=2.567877 Y=Y+.1471263*FCT(X) X=1.026665 Y=Y+.4218313*FCT(X) X=.1930437 Y=Y+.4093190*FCT(X) RETURN END SUBROUTINE QL8(FCT,Y) X=22.86313 Y=.1048001E-8*FCT(X) X=15.74068 Y=Y+.8485747E-6*FCT(X) X=10.75852 Y=Y+.9076509E-4*FCT(X) X=7.045905 Y=Y+.2794536E-2*FCT(X) X=4.266700 Y=Y+.03334349*FCT(X) X=2.251087 Y=Y+.1757950*FCT(X) X=.9037018 Y=Y+.4187868*FCT(X) X=.1702796 Y=Y+.3691886*FCT(X) RETURN END SUBROUTINE QL9(FCT,Y) X=26.37407 Y=.3290874E-10*FCT(X) X=18.83360 Y=Y+.4110769E-7*FCT(X) X=13.46624 Y=Y+.6592123E-5*FCT(X) X=9.372985 Y=Y+.3052498E-3*FCT(X) X=6.204957 Y=Y+.005599627*FCT(X) X=3.783474 Y=Y+.04746056*FCT(X) X=2.005135 Y=Y+.1992875*FCT(X) X=.8072200 Y=Y+.4112140*FCT(X) X=.1523222 Y=Y+.3361264*FCT(X) RETURN END SUBROUTINE QSF(H,Y,Z,NDIM) DIMENSION Y(1),Z(1) HT=.3333333*H IF(NDIM-5)7,8,1 1 SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(3)+AUX1+Y(5)) AUX2=HT*(Y(1)+3.875*(Y(2)+Y(5))+2.625*(Y(3)+Y(4))+Y(6)) SUM2=Y(5)+Y(5) SUM2=SUM2+SUM2 SUM2=AUX2-HT*(Y(4)+SUM2+Y(6)) Z(1)=0. AUX=Y(3)+Y(3) AUX=AUX+AUX Z(2)=SUM2-HT*(Y(2)+AUX+Y(4)) Z(3)=SUM1 Z(4)=SUM2 IF(NDIM-6)5,5,2 2 DO 4 I=7,NDIM,2 SUM1=AUX1 SUM2=AUX2 AUX1=Y(I-1)+Y(I-1) AUX1=AUX1+AUX1 AUX1=SUM1+HT*(Y(I-2)+AUX1+Y(I)) Z(I-2)=SUM1 IF(I-NDIM)3,6,6 3 AUX2=Y(I)+Y(I) AUX2=AUX2+AUX2 AUX2=SUM2+HT*(Y(I-1)+AUX2+Y(I+1)) 4 Z(I-1)=SUM2 5 Z(NDIM-1)=AUX1 Z(NDIM)=AUX2 RETURN 6 Z(NDIM-1)=SUM2 Z(NDIM)=AUX1 RETURN 7 IF(NDIM-3)12,11,8 8 SUM2=1.125*HT*(Y(1)+Y(2)+Y(2)+Y(2)+Y(3)+Y(3)+Y(3)+Y(4)) SUM1=Y(2)+Y(2) SUM1=SUM1+SUM1 SUM1=HT*(Y(1)+SUM1+Y(3)) Z(1)=0. AUX1=Y(3)+Y(3) AUX1=AUX1+AUX1 Z(2)=SUM2-HT*(Y(2)+AUX1+Y(4)) IF(NDIM-5)10,9,9 9 AUX1=Y(4)+Y(4) AUX1=AUX1+AUX1 Z(5)=SUM1+HT*(Y(3)+AUX1+Y(5)) 10 Z(3)=SUM1 Z(4)=SUM2 RETURN 11 SUM1=HT*(1.25*Y(1)+Y(2)+Y(2)-.25*Y(3)) SUM2=Y(2)+Y(2) SUM2=SUM2+SUM2 Z(3)=HT*(Y(1)+SUM2+Y(3)) Z(1)=0. Z(2)=SUM1 12 RETURN END SUBROUTINE QTEST(A,N,M,Q,NDF) DIMENSION A(1) RSQ=0.0 GD=0.0 DO 20 I=1,N TR=0.0 IJ=I-N DO 10 J=1,M IJ=IJ+N 10 TR=TR+A(IJ) GD=GD+TR 20 RSQ=RSQ+TR*TR CSQ=0.0 IJ=0 DO 40 J=1,M TC=0.0 DO 30 I=1,N IJ=IJ+1 30 TC=TC+A(IJ) 40 CSQ=CSQ+TC*TC FM=M Q=(FM-1.0)*(FM*CSQ-GD*GD)/(FM*GD-RSQ) NDF=M-1 RETURN END SUBROUTINE QTFE(H,Y,Z,NDIM) DIMENSION Y(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 HH=.5*H DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+HH*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE QTFG(X,Y,Z,NDIM) DIMENSION X(1),Y(1),Z(1) SUM2=0. IF(NDIM-1)4,3,1 1 DO 2 I=2,NDIM SUM1=SUM2 SUM2=SUM2+.5*(X(I)-X(I-1))*(Y(I)+Y(I-1)) 2 Z(I-1)=SUM1 3 Z(NDIM)=SUM2 4 RETURN END SUBROUTINE RADD(A,IRA,R,IRR,N,M,MS,L) DIMENSION A(1),R(1) IR=IRR-L DO 2 J=1,M IR=IR+L CALL LOC(IRA,J,IA,N,M,MS) IF(IA) 1,2,1 1 R(IR)=R(IR)+A(IA) 2 CONTINUE RETURN END SUBROUTINE RANDU(IX,IY,YFL) IY=IX*65539 IF(IY)5,6,6 5 IY=IY+2147483647+1 6 YFL=IY YFL=YFL*.4656613E-9 RETURN END SUBROUTINE RANK(A,R,N) DIMENSION A(1),R(1) DO 10 I=1,N 10 R(I)=0.0 DO 100 I=1,N IF(R(I)) 20, 20, 100 20 SMALL=0.0 EQUAL=0.0 X=A(I) DO 50 J=1,N IF(A(J)-X) 30, 40, 50 30 SMALL=SMALL+1.0 GO TO 50 40 EQUAL=EQUAL+1.0 R(J)=-1.0 50 CONTINUE IF(EQUAL-1.0) 60, 60, 70 60 R(I)=SMALL+1.0 GO TO 100 70 P=SMALL + (EQUAL + 1.0)*0.5 DO 90 J=I,N IF(R(J)+1.0) 90, 80, 90 80 R(J)=P 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE RCPY(A,L,R,N,M,MS) DIMENSION A(1),R(1) DO 3 J=1,M CALL LOC(L,J,LJ,N,M,MS) IF(LJ) 1,2,1 1 R(J)=A(LJ) GO TO 3 2 R(J)=0.0 3 CONTINUE RETURN END SUBROUTINE RCUT(A,L,R,S,N,M,MS) DIMENSION A(1),R(1),S(1) IR=0 IS=0 DO 70 J=1,M DO 70 I=1,N IF(I-L) 20,10,10 10 IS=IS+1 S(IS)=0.0 GO TO 30 20 IR=IR+1 R(IR)=0.0 30 CALL LOC(I,J,IJ,N,M,MS) IF(IJ) 40,70,40 40 IF(I-L) 60,50,50 50 S(IS)=A(IJ) GO TO 70 60 R(IR)=A(IJ) 70 CONTINUE RETURN END FUNCTION RECP(E) BIG=1.0E33 IF(E) 1,2,1 1 RECP=1.0/E RETURN 2 RECP=SIGN(BIG,E) RETURN END SUBROUTINE RHARM(A,M,INV,S,IFERR) DIMENSION A(1),L(3),INV(1),S(1) IFSET=1 L(1)=M L(2)=0 L(3)=0 NTOT=2**M NTOT2 = 2*NTOT FN = NTOT DO 3 I = 2,NTOT2,2 3 A(I) = -A(I) DO 6 I = 1,NTOT2 6 A(I) = A(I)/FN CALL HARM(A,L,INV,S ,IFSET,IFERR) 21 DO 52 I=1,NTOT,2 J0=NTOT2+2-I A(J0)=A(J0-2) 52 A(J0+1)=A(J0-1) A(NTOT2+3)=A(1) A(NTOT2+4)=A(2) K0=NTOT+1 DO 104 I=1,K0,2 K1=NTOT2-I+4 AP1RE=.5*(A(I)+A(K1)) AP2RE=-.5*(A(I+1)+A(K1+1)) AP1IM=.5*(-A(I+1)+A(K1+1)) AP2IM=-.5*(A(I)-A(K1)) A(I)=AP1RE A(I+1)=AP1IM A(K1)=AP2RE 104 A(K1+1)=AP2IM NTO = NTOT/2 110 NT=NTO+1 DEL=3.1415927/FLOAT(NTOT) SS=SIN(DEL) SC=COS(DEL) SI=0.0 CO=1.0 114 DO 116 I=1,NT K6=NTOT2-2*I+5 AP2RE=A(K6)*CO+A(K6+1)*SI AP2IM=-A(K6)*SI+A(K6+1)*CO CIRE=.5*(A(2*I-1)+AP2RE) CIIM=.5*(A(2*I)+AP2IM) CNIRE=.5*(A(2*I-1)-AP2RE) CNIIM=.5*(A(2*I)-AP2IM) A(2*I-1)=CIRE A(2*I)=CIIM A(K6)=CNIRE A(K6+1)=-CNIIM SIS=SI SI=SI*SC+CO*SS 116 CO=CO*SC-SIS*SS DO 117 I=1,NTOT,2 K8=NTOT+4+I A(K8-2)=A(K8) 117 A(K8-1)=A(K8+1) DO 500 I=3,NTOT2,2 A(I) = 2. * A(I) 500 A(I + 1) = -2. * A(I + 1) RETURN END SUBROUTINE RINT(A,N,M,LA,LB) DIMENSION A(1) LAJ=LA-N LBJ=LB-N DO 3 J=1,M LAJ=LAJ+N LBJ=LBJ+N SAVE=A(LAJ) A(LAJ)=A(LBJ) 3 A(LBJ)=SAVE RETURN END SUBROUTINE RKGS(PRMT,Y,DERY,NDIM,IHLF,FCT,OUTP,AUX) DIMENSION Y(1),DERY(1),AUX(8,1),A(4),B(4),C(4),PRMT(1) DO 1 I=1,NDIM 1 AUX(8,I)=.06666667*DERY(I) X=PRMT(1) XEND=PRMT(2) H=PRMT(3) PRMT(5)=0. CALL FCT(X,Y,DERY) IF(H*(XEND-X))38,37,2 2 A(1)=.5 A(2)=.2928932 A(3)=1.707107 A(4)=.1666667 B(1)=2. B(2)=1. B(3)=1. B(4)=2. C(1)=.5 C(2)=.2928932 C(3)=1.707107 C(4)=.5 DO 3 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=0. 3 AUX(6,I)=0. IREC=0 H=H+H IHLF=-1 ISTEP=0 IEND=0 4 IF((X+H-XEND)*H)7,6,5 5 H=XEND-X 6 IEND=1 7 CALL OUTP(X,Y,DERY,IREC,NDIM,PRMT) IF(PRMT(5))40,8,40 8 ITEST=0 9 ISTEP=ISTEP+1 J=1 10 AJ=A(J) BJ=B(J) CJ=C(J) DO 11 I=1,NDIM R1=H*DERY(I) R2=AJ*(R1-BJ*AUX(6,I)) Y(I)=Y(I)+R2 R2=R2+R2+R2 11 AUX(6,I)=AUX(6,I)+R2-CJ*R1 IF(J-4)12,15,15 12 J=J+1 IF(J-3)13,14,13 13 X=X+.5*H 14 CALL FCT(X,Y,DERY) GOTO 10 15 IF(ITEST)16,16,20 16 DO 17 I=1,NDIM 17 AUX(4,I)=Y(I) ITEST=1 ISTEP=ISTEP+ISTEP-2 18 IHLF=IHLF+1 X=X-H H=.5*H DO 19 I=1,NDIM Y(I)=AUX(1,I) DERY(I)=AUX(2,I) 19 AUX(6,I)=AUX(3,I) GOTO 9 20 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)21,23,21 21 CALL FCT(X,Y,DERY) DO 22 I=1,NDIM AUX(5,I)=Y(I) 22 AUX(7,I)=DERY(I) GOTO 9 23 DELT=0. DO 24 I=1,NDIM 24 DELT=DELT+AUX(8,I)*ABS(AUX(4,I)-Y(I)) IF(DELT-PRMT(4))28,28,25 25 IF(IHLF-10)26,36,36 26 DO 27 I=1,NDIM 27 AUX(4,I)=AUX(5,I) ISTEP=ISTEP+ISTEP-4 X=X-H IEND=0 GOTO 18 28 CALL FCT(X,Y,DERY) DO 29 I=1,NDIM AUX(1,I)=Y(I) AUX(2,I)=DERY(I) AUX(3,I)=AUX(6,I) Y(I)=AUX(5,I) 29 DERY(I)=AUX(7,I) CALL OUTP(X-H,Y,DERY,IHLF,NDIM,PRMT) IF(PRMT(5))40,30,40 30 DO 31 I=1,NDIM Y(I)=AUX(1,I) 31 DERY(I)=AUX(2,I) IREC=IHLF IF(IEND)32,32,39 32 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H IF(IHLF)4,33,33 33 IMOD=ISTEP/2 IF(ISTEP-IMOD-IMOD)4,34,4 34 IF(DELT-.02*PRMT(4))35,35,4 35 IHLF=IHLF-1 ISTEP=ISTEP/2 H=H+H GOTO 4 36 IHLF=11 CALL FCT(X,Y,DERY) GOTO 39 37 IHLF=12 GOTO 39 38 IHLF=13 39 CALL OUTP(X,Y,DERY,IHLF,NDIM,PRMT) 40 RETURN END SUBROUTINE RK1(FUN,HI,XI,YI,XF,YF,ANSX,ANSY,IER) IER=0 IF(XF-XI) 11,11,12 11 ANSX=XI ANSY=YI RETURN 12 H=HI IF(HI) 16,14,20 14 IER=1 ANSX=XI ANSY=0.0 RETURN 16 H=-HI 20 XN=XI YN=YI HNEW=H JUMP=1 GO TO 170 25 XN1=XX YN1=YY IF(XN1-XF)50,30,40 30 ANSX=XF ANSY=YN1 GO TO 160 40 HNEW=XF-XN JUMP=2 GO TO 170 45 ANSX=XX ANSY=YY GO TO 160 50 IF((YN1-YF)*(YF-YN))60,70,110 60 YN=YN1 XN=XN1 GO TO 170 70 IF(YN1-YF)80,100,80 80 ANSY=YN ANSX=XN GO TO 160 100 ANSY=YN1 ANSX=XN1 GO TO 160 110 DO 140 I=1,10 HNEW=((YF-YN )/(YN1-YN))*(XN1-XN) JUMP=3 GO TO 170 115 XNEW=XX YNEW=YY IF(YNEW-YF)120,150,130 120 YN=YNEW XN=XNEW GO TO 140 130 YN1=YNEW XN1=XNEW 140 CONTINUE 150 ANSX=XNEW ANSY=YF 160 RETURN 170 H2=HNEW/2.0 T1=HNEW*FUN(XN,YN) T2=HNEW*FUN(XN+H2,YN+T1/2.0) T3=HNEW*FUN(XN+H2,YN+T2/2.0) T4=HNEW*FUN(XN+HNEW,YN+T3) YY=YN+(T1+2.0*T2+2.0*T3+T4)/6.0 XX=XN+HNEW GO TO (25,45,115), JUMP END SUBROUTINE RK2(FUN,H,XI,YI,K,N,VEC) DIMENSION VEC(1) H2=H/2. Y=YI X=XI DO 2 I=1,N DO 1 J=1,K T1=H*FUN(X,Y) T2=H*FUN(X+H2,Y+T1/2.) T3=H*FUN(X+H2,Y+T2/2.) T4=H*FUN(X+H,Y+T3) Y= Y+(T1+2.*T2+2.*T3+T4)/6. 1 X=X+H 2 VEC(I)=Y RETURN END SUBROUTINE RSLMC (A,AF,B,X,N,EPSI,IER,IA,V,PER) DIMENSION A(1),AF(1),B(1),X(1),V(1),PER(1) DOUBLE PRECISION DP D0=0. IER=0 ITE=0 DO 10 I=1,N V(I)=B(I) 10 X(I)=0. 20 ITE=ITE+1 DO 30 I=1,N K=PER(I) IF (K-I)25,30,25 25 D1=V(K) V(K)=V(I) V(I)=D1 30 CONTINUE DO 50 I=2,N IM1=I-1 DP=V(I) IK=I DO 40 K=1,IM1 DP=DP-1.D0*AF(IK)*V(K) 40 IK=IK+IA 50 V(I)=DP IF(AF(IK)) 58,54,58 54 IER=4 GO TO 82 58 V(N)=DP/AF(IK) DO 70 I=2,N IM1=N-I+1 INF=IM1+1 DP=V(IM1) IK=(IM1-1)*IA+IM1 D1=AF(IK) DO 60 K=INF,N IK=IK+IA 60 DP=DP-1.D0*AF(IK)*V(K) 70 V(IM1)=DP/D1 D1=0. D2=0. KLE=0 DO 80 I=1,N D1=D1+ABS(V(I)) D2=D2+ABS(X(I)) IF (ABS(V(I))-EPSI*ABS(X(I))) 80,80,75 75 KLE=1 80 CONTINUE IF (KLE)140,82,85 82 RETURN 85 IF (ITE-1)140,90,87 87 IF (D0-2.*D1)120,90,90 90 DO 95 I=1,N 95 X(I)=X(I)+V(I) DO 110 I=1,N DP=B(I) IK=I DO 100 K=1,N DP=DP-1.D0*A(IK)*X(K) 100 IK=IK+IA 110 V(I)=DP D0=D1 GO TO 20 120 IF(ITE-2)140,140,125 125 IF (D1-EPSI*D2)127,127,130 127 IER=1 RETURN 130 IER=2 EPSI=D1/D2 RETURN 140 IER=3 RETURN END SUBROUTINE RSRT(A,B,R,N,M,MS) DIMENSION A(1),B(1),R(1) DO 10 I=1,N R(I)=B(I) I2=I+N 10 R(I2)=I L=N+1 20 ISORT=0 L=L-1 DO 40 I=2,L IF(R(I)-R(I-1)) 30,40,40 30 ISORT=1 RSAVE=R(I) R(I)=R(I-1) R(I-1)=RSAVE I2=I+N SAVER=R(I2) R(I2)=R(I2-1) R(I2-1)=SAVER 40 CONTINUE IF(ISORT) 20,50,20 50 DO 80 I=1,N I2=I+N IN=R(I2) IR=I-N DO 80 J=1,M IR=IR+N CALL LOC(IN,J,IA,N,M,MS) IF(IA) 60,70,60 60 R(IR)=A(IA) GO TO 80 70 R(IR)=0 80 CONTINUE RETURN END SUBROUTINE RSUM(A,R,N,M,MS) DIMENSION A(1),R(1) DO 3 I=1,N R(I)=0.0 DO 3 J=1,M CALL LOC(I,J,IJ,N,M,MS) IF(IJ) 2,3,2 2 R(I)=R(I)+A(IJ) 3 CONTINUE RETURN END SUBROUTINE RTAB(A,B,R,S,N,M,MS,L) DIMENSION A(1),B(1),R(1),S(1) CALL LOC(M,L,IT,M,L,0) DO 10 IR=1,IT 10 R(IR)=0.0 DO 20 IS=1,L 20 S(IS)=0.0 S(L+1)=0.0 DO 60 I=1,N JR=B(I) IF (JR-1) 50,40,30 30 IF (JR-L) 40,40,50 40 CALL RADD (A,I,R,JR,N,M,MS,L) S(JR)=S(JR)+1.0 GO TO 60 50 S(L+1)=S(L+1)+1.0 60 CONTINUE RETURN END SUBROUTINE RTIE(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) NN=N IR=0 NX=NN MSX=MSA DO 9 J=1,M DO 8 II=1,2 DO 7 I=1,NN IR=IR+1 R(IR)=0.0 CALL LOC(I,J,IJ,NN,M,MSX) IF(IJ) 2,7,2 2 GO TO(3,4),II 3 R(IR)=A(IJ) GO TO 7 4 R(IR)=B(IJ) 7 CONTINUE MSX=MSB 8 NN=L MSX=MSA 9 NN=NX RETURN END SUBROUTINE RTMI(X,F,FCT,XLI,XRI,EPS,IEND,IER) IER=0 XL=XLI XR=XRI X=XL TOL=X F=FCT(TOL) IF(F)1,16,1 1 FL=F X=XR TOL=X F=FCT(TOL) IF(F)2,16,2 2 FR=F IF(SIGN(1.,FL)+SIGN(1.,FR))25,3,25 3 I=0 TOLF=100.*EPS 4 I=I+1 DO 13 K=1,IEND X=.5*(XL+XR) TOL=X F=FCT(TOL) IF(F)5,16,5 5 IF(SIGN(1.,F)+SIGN(1.,FR))7,6,7 6 TOL=XL XL=XR XR=TOL TOL=FL FL=FR FR=TOL 7 TOL=F-FL A=F*TOL A=A+A IF(A-FR*(FR-FL))8,9,9 8 IF(I-IEND)17,17,9 9 XR=X FR=F TOL=EPS A=ABS(XR) IF(A-1.)11,11,10 10 TOL=TOL*A 11 IF(ABS(XR-XL)-TOL)12,12,13 12 IF(ABS(FR-FL)-TOLF)14,14,13 13 CONTINUE IER=1 14 IF(ABS(FR)-ABS(FL))16,16,15 15 X=XL F=FL 16 RETURN 17 A=FR-F DX=(X-XL)*FL*(1.+F*(A-TOL)/(A*(FR-FL)))/TOL XM=X FM=F X=XL-DX TOL=X F=FCT(TOL) IF(F)18,16,18 18 TOL=EPS A=ABS(X) IF(A-1.)20,20,19 19 TOL=TOL*A 20 IF(ABS(DX)-TOL)21,21,22 21 IF(ABS(F)-TOLF)16,16,22 22 IF(SIGN(1.,F)+SIGN(1.,FL))24,23,24 23 XR=X FR=F GO TO 4 24 XL=X FL=F XR=XM FR=FM GO TO 4 25 IER=2 RETURN END SUBROUTINE RTNI(X,F,DERF,FCT,XST,EPS,IEND,IER) IER=0 X=XST TOL=X CALL FCT(TOL,F,DERF) TOLF=100.*EPS DO 6 I=1,IEND IF(F)1,7,1 1 IF(DERF)2,8,2 2 DX=F/DERF X=X-DX TOL=X CALL FCT(TOL,F,DERF) TOL=EPS A=ABS(X) IF(A-1.)4,4,3 3 TOL=TOL*A 4 IF(ABS(DX)-TOL)5,5,6 5 IF(ABS(F)-TOLF)7,7,6 6 CONTINUE IER=1 7 RETURN 8 IER=2 RETURN END SUBROUTINE RTWI(X,VAL,FCT,XST,EPS,IEND,IER) IER=0 TOL=XST X=FCT(TOL) A=X-XST B=-A TOL=X VAL=X-FCT(TOL) DO 6 I=1,IEND IF(VAL)1,7,1 1 B=B/VAL-1. IF(B)2,8,2 2 A=A/B X=X+A B=VAL TOL=X VAL=X-FCT(TOL) TOL=EPS D=ABS(X) IF(D-1.)4,4,3 3 TOL=TOL*D 4 IF(ABS(A)-TOL)5,5,6 5 IF(ABS(VAL)-10.*TOL)7,7,6 6 CONTINUE IER=1 7 RETURN 8 IER=2 RETURN END SUBROUTINE SADD(A,C,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) DO 1 I=1,IT 1 R(I)=A(I)+C RETURN END SUBROUTINE SCLA(A,C,N,M,MS) DIMENSION A(1) CALL LOC(N,M,IT,N,M,MS) DO 1 I=1,IT 1 A(I)=C RETURN END SUBROUTINE SCMA(A,C,N,LA,LB) DIMENSION A(1) ILA=N*(LA-1) ILB=N*(LB-1) DO 3 I=1,N ILA=ILA+1 ILB=ILB+1 IF(LB) 1,2,1 1 A(ILB)=A(ILA)*C+A(ILB) GO TO 3 2 A(ILA)=A(ILA)*C 3 CONTINUE RETURN END SUBROUTINE SDIV(A,C,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) IF(C) 2,1,2 1 IT=1 2 DO 3 I=1,IT 3 R(I)=A(I)/C RETURN END SUBROUTINE SE13(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) IF(NDIM-3)3,1,1 1 B=.1666667*(5.*Y(1)+Y(2)+Y(2)-Y(3)) C=.1666667*(5.*Y(NDIM)+Y(NDIM-1)+Y(NDIM-1)-Y(NDIM-2)) DO 2 I=3,NDIM A=B B=.3333333*(Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-2)=A Z(NDIM-1)=B Z(NDIM)=C IER=0 RETURN 3 IER=-1 RETURN END SUBROUTINE SE15(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) IF(NDIM-5)3,1,1 1 A=Y(1)+Y(1) C=Y(2)+Y(2) B=.2*(A+Y(1)+C+Y(3)-Y(5)) C=.1*(A+A+C+Y(2)+Y(3)+Y(3)+Y(4)) DO 2 I=5,NDIM A=B B=C C=.2*(Y(I-4)+Y(I-3)+Y(I-2)+Y(I-1)+Y(I)) 2 Z(I-4)=A A=Y(NDIM)+Y(NDIM) 0A=.1*(A+A+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-1)+Y(NDIM-2)+Y(NDIM-2) 1 +Y(NDIM-3)) Z(NDIM-3)=B Z(NDIM-2)=C Z(NDIM-1)=A Z(NDIM)=A+A-C IER=0 RETURN 3 IER=-1 RETURN END SUBROUTINE SE35(Y,Z,NDIM,IER) DIMENSION Y(1),Z(1) IF(NDIM-5)4,1,1 1 B=Y(1) C=Y(2) DO 3 I=5,NDIM A=B B=C C=Y(I-2) D=C-B-Y(I-1) D=D+D+C D=D+D+A+Y(I) IF(I-5)2,2,3 2 Z(1)=A-.01428571*D Z(2)=B+.05714286*D 3 Z(I-2)=C-.08571429*D Z(NDIM-1)=Y(NDIM-1)+.05714286*D Z(NDIM)=Y(NDIM)-.01428571*D IER=0 RETURN 4 IER=-1 RETURN END SUBROUTINE SG13(X,Y,Z,NDIM,IER) DIMENSION X(1),Y(1),Z(1) IF(NDIM-3)7,1,1 1 DO 6 I=3,NDIM XM=.3333333*(X(I-2)+X(I-1)+X(I)) YM=.3333333*(Y(I-2)+Y(I-1)+Y(I)) T1=X(I-2)-XM T2=X(I-1)-XM T3=X(I)-XM XM=T1*T1+T2*T2+T3*T3 IF(XM)3,3,2 2 XM=(T1*(Y(I-2)-YM)+T2*(Y(I-1)-YM)+T3*(Y(I)-YM))/XM 3 IF(I-3)4,4,5 4 H=XM*T1+YM 5 Z(I-2)=H 6 H=XM*T2+YM Z(NDIM-1)=H Z(NDIM)=XM*T3+YM IER=0 RETURN 7 IER=-1 RETURN END SUBROUTINE SICI(SI,CI,X) Z=ABS(X) IF(Z-4.)1,1,4 1 Y=(4.-Z)*(4.+Z) SI=-1.570797E0 IF(Z)3,2,3 2 CI=-1.E33 RETURN 3 SI=X*(((((1.753141E-9*Y+1.568988E-7)*Y+1.374168E-5)*Y+6.939889E-4) 1*Y+1.964882E-2)*Y+4.395509E-1+SI/X) CI=((5.772156E-1+ALOG(Z))/Z-Z*(((((1.386985E-10*Y+1.584996E-8)*Y 1+1.725752E-6)*Y+1.185999E-4)*Y+4.990920E-3)*Y+1.315308E-1))*Z RETURN 4 SI=SIN(Z) Y=COS(Z) Z=4./Z U=((((((((4.048069E-3*Z-2.279143E-2)*Z+5.515070E-2)*Z-7.261642E-2) 1*Z+4.987716E-2)*Z-3.332519E-3)*Z-2.314617E-2)*Z-1.134958E-5)*Z 2+6.250011E-2)*Z+2.583989E-10 V=(((((((((-5.108699E-3*Z+2.819179E-2)*Z-6.537283E-2)*Z 1+7.902034E-2)*Z-4.400416E-2)*Z-7.945556E-3)*Z+2.601293E-2)*Z 2-3.764000E-4)*Z-3.122418E-2)*Z-6.646441E-7)*Z+2.500000E-1 CI=Z*(SI*V-Y*U) SI=-Z*(SI*U+Y*V) IF(X)5,6,6 5 SI=3.141593E0-SI 6 RETURN END SUBROUTINE SIGNT (N,A,B,K,M,P,IE) DIMENSION A(1),B(1) DOUBLE PRECISION FN,FD IE=0 K=0 MPLUS=0 MMINS=0 DO 40 I=1,N D=A(I)-B(I) IF(D) 20, 40, 30 20 K=K+1 MMINS=MMINS+1 GO TO 40 30 K=K+1 MPLUS=MPLUS+1 40 CONTINUE IF(K) 41,41,42 41 IE=1 P=1.0 M=0 GO TO 95 42 FK=K IF(MPLUS-MMINS) 45, 45, 50 45 M=MPLUS GO TO 55 50 M=MMINS 55 IF(K-25) 60, 60, 77 60 P=1.0 IF(M) 75, 75, 65 65 FN=1.0 FD=1.0 DO 70 I=1,M FI=I FN=FN*(FK-(FI-1.0)) FD=FD*FI 70 P=P+FN/FD 75 P=P/(2.0**K) GO TO 95 77 U=0.5*FK S=0.5*SQRT(FK) FM=M IF(FM-U) 80, 85, 85 80 CON=0.5 GO TO 90 85 CON=0.0 90 Z=(FM+CON-U)/S CALL NDTR (Z,P,D) 95 RETURN END SUBROUTINE SIMQ(A,B,N,KS) DIMENSION A(1),B(1) TOL=0.0 KS=0 JJ=-N DO 65 J=1,N JY=J+1 JJ=JJ+N+1 BIGA=0 IT=JJ-J DO 30 I=J,N IJ=IT+I IF(ABS(BIGA)-ABS(A(IJ))) 20,30,30 20 BIGA=A(IJ) IMAX=I 30 CONTINUE IF(ABS(BIGA)-TOL) 35,35,40 35 KS=1 RETURN 40 I1=J+N*(J-2) IT=IMAX-J DO 50 K=J,N I1=I1+N I2=I1+IT SAVE=A(I1) A(I1)=A(I2) A(I2)=SAVE 50 A(I1)=A(I1)/BIGA SAVE=B(IMAX) B(IMAX)=B(J) B(J)=SAVE/BIGA IF(J-N) 55,70,55 55 IQS=N*(J-1) DO 65 IX=JY,N IXJ=IQS+IX IT=J-IX DO 60 JX=JY,N IXJX=N*(JX-1)+IX JJX=IXJX+IT 60 A(IXJX)=A(IXJX)-(A(IXJ)*A(JJX)) 65 B(IX)=B(IX)-(B(J)*A(IXJ)) 70 NY=N-1 IT=N*N DO 80 J=1,NY IA=IT-J IB=N-J IC=N DO 80 K=1,J B(IB)=B(IB)-A(IA)*B(IC) IA=IA-N 80 IC=IC-1 RETURN END SUBROUTINE SINV(A,N,EPS,IER) DIMENSION A(1) DOUBLE PRECISION DIN,WORK CALL MFSD(A,N,EPS,IER) IF(IER) 9,1,1 1 IPIV=N*(N+1)/2 IND=IPIV DO 6 I=1,N DIN=1.D0/DBLE(A(IPIV)) A(IPIV)=DIN MIN=N KEND=I-1 LANF=N-KEND IF(KEND) 5,5,2 2 J=IND DO 4 K=1,KEND WORK=0.D0 MIN=MIN-1 LHOR=IPIV LVER=J DO 3 L=LANF,MIN LVER=LVER+1 LHOR=LHOR+L 3 WORK=WORK+DBLE(A(LVER)*A(LHOR)) A(J)=-WORK*DIN 4 J=J-MIN 5 IPIV=IPIV-MIN 6 IND=IND-1 DO 8 I=1,N IPIV=IPIV+I J=IPIV DO 8 K=I,N WORK=0.D0 LHOR=J DO 7 L=K,N LVER=LHOR+K-I WORK=WORK+DBLE(A(LHOR)*A(LVER)) 7 LHOR=LHOR+L A(J)=WORK 8 J=J+K 9 RETURN END SUBROUTINE SMIRN(X,Y) IF(X-.27)1,1,2 1 Y=0.0 GO TO 9 2 IF(X-1.0)3,6,6 3 Q1=EXP(-1.233701/X**2) Q2=Q1*Q1 Q4=Q2*Q2 Q8=Q4*Q4 IF(Q8-1.0E-25)4,5,5 4 Q8=0.0 5 Y=(2.506628/X)*Q1*(1.0+Q8*(1.0+Q8*Q8)) GO TO 9 6 IF(X-3.1)8,7,7 7 Y=1.0 GO TO 9 8 Q1=EXP(-2.0*X*X) Q2=Q1*Q1 Q4=Q2*Q2 Q8=Q4*Q4 Y=1.0-2.0*(Q1-Q4+Q8*(Q1-Q8)) 9 RETURN END SUBROUTINE SMO (A,N,W,M,L,R) DIMENSION A(1),W(1),R(1) DO 110 I=1,N 110 R(I)=0.0 IL=(L*(M-1))/2+1 IH=N-(L*(M-1))/2 DO 120 I=IL,IH K=I-IL+1 DO 120 J=1,M IP=(J*L)-L+K 120 R(I)=R(I)+A(IP)*W(J) RETURN END SUBROUTINE SMPY(A,C,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) DO 1 I=1,IT 1 R(I)=A(I)*C RETURN END SUBROUTINE SRANK(A,B,R,N,RS,T,NDF,NR) DIMENSION A(1),B(1),R(1) FNNN=N*N*N-N IF(NR-1) 5, 10, 5 5 CALL RANK (A,R,N) CALL RANK (B,R(N+1),N) GO TO 40 10 DO 20 I=1,N 20 R(I)=A(I) DO 30 I=1,N J=I+N 30 R(J)=B(I) 40 D=0.0 DO 50 I=1,N J=I+N 50 D=D+(R(I)-R(J))*(R(I)-R(J)) KT=1 CALL TIE (R,N,KT,TSA) CALL TIE (R(N+1),N,KT,TSB) IF(TSA) 60,55,60 55 IF(TSB) 60,57,60 57 RS=1.0-6.0*D/FNNN GO TO 70 60 X=FNNN/12.0-TSA Y=X+TSA-TSB RS=(X+Y-D)/(2.0*(SQRT(X*Y))) T=0.0 70 IF(N-10) 80,75,75 75 T=RS*SQRT(FLOAT(N-2)/(1.0-RS*RS)) 80 NDF=N-2 RETURN END SUBROUTINE SRATE (N,K,X,IE) DIMENSION X(1) IE=0 NP4=4*N+1 NP9=NP4+NP4+N-2 DO 1 I=NP4,NP9 1 X(I)=0.0 IF (K) 2,2,3 2 IE=1 GO TO 45 3 IF(K-N) 4,4,2 4 DO 9 I=1,N NP4=I+N NP9=NP4+N NP1=NP9+N IF(INT(X(I)-X(NP4)-X(NP9)-X(NP1)+.01)) 5,6,6 5 IE=2 GO TO 45 6 IF(I-N) 7,9,9 7 IF (INT(X(I+1)-X(I)+X(NP4)+X(NP9)+X(NP1)+.01)) 8,9,8 8 IE=3 GO TO 45 9 CONTINUE 15 L1=0 L2=L1+N L3=L2+N L4=L3+N L5=L4+N L6=L5+N L7=L6+N L8=L7+N L9=L8+N LD=L2 LE=L5 LQ=L6 SUM=0.0 DO 40 I=1,K L1=L1+1 L3=L3+1 L4=L4+1 L5=L5+1 X(L5)=X(L1)-(X(L3)+X(L4))/2.0 L2=L2+1 L6=L6+1 X(L6)=X(L2)/X(L5) L7=L7+1 X(L7)=1.0-X(L6) L8=L8+1 IF (I-1) 20, 20, 25 20 X(L8)=X(L7) GO TO 30 25 X(L8)=X(L8-1)*X(L7) 30 L9=L9+1 SUM=SUM+X(L6)/(X(L5)-X(L2)) 40 X(L9)=X(L8)*SQRT(SUM) 45 RETURN END SUBROUTINE SRMA(A,C,N,M,LA,LB) DIMENSION A(1) LAJ=LA-N LBJ=LB-N DO 3 J=1,M LAJ=LAJ+N LBJ=LBJ+N IF(LB) 1,2,1 1 A(LBJ)=A(LAJ)*C+A(LBJ) GO TO 3 2 A(LAJ)=A(LAJ)*C 3 CONTINUE RETURN END SUBROUTINE SSUB(A,C,R,N,M,MS) DIMENSION A(1),R(1) CALL LOC(N,M,IT,N,M,MS) DO 1 I=1,IT 1 R(I)=A(I)-C RETURN END SUBROUTINE STPRG (M,N,D,XBAR,IDX,PCT,NSTEP,ANS,L,B,S,T,LL,IER) DIMENSION D(1),XBAR(1),IDX(1),NSTEP(1),ANS(1),L(1),B(1),S(1),T(1), 1LL(1) IER=0 ONM=N-1 NFO=0 NSTEP(3)=0 ANS(3)=0.0 ANS(4)=0.0 NSTOP=0 DO 30 I=1,M LL(I)=1 IF(IDX(I)) 30, 30, 10 10 IF(IDX(I)-2) 15, 20, 25 15 NFO=NFO+1 IDX(NFO)=I GO TO 30 20 NSTEP(3)=NSTEP(3)+1 LL(I)=-1 GO TO 30 25 MY=I NSTEP(1)=MY LY=M*(MY-1) LYP=LY+MY ANS(5)=D(LYP) 30 CONTINUE NSTEP(2)=NFO MX=M-NSTEP(3)-1 DO 140 NL=1,MX RD=0 IF(NL-NFO) 35, 35, 55 35 DO 50 I=1,NFO K=IDX(I) IF(LL(K)) 50, 50, 40 40 LYP=LY+K IP=M*(K-1)+K RE=D(LYP)*D(LYP)/D(IP) IF(RD-RE) 45, 50, 50 45 RD=RE NEW=K 50 CONTINUE GO TO 75 55 DO 70 I=1,M IF(I-MY) 60, 70, 60 60 IF(LL(I)) 70, 70, 62 62 LYP=LY+I IP=M*(I-1)+I RE=D(LYP)*D(LYP)/D(IP) IF(RD-RE) 64, 70, 70 64 RD=RE NEW=I 70 CONTINUE 75 IF(RD) 77,77,76 76 IF(ANS(5)-(ANS(3)+RD))77,77,78 77 IER=1 GO TO 150 78 RE=RD/ANS(5) IF(RE-PCT) 150, 80, 80 80 LL(NEW)=0 L(NL)=NEW ANS(1)=RD ANS(2)=RE ANS(3)=ANS(3)+RD ANS(4)=ANS(4)+RE NSTEP(4)=NL NSTEP(5)=NEW 85 ANS(6)= SQRT(ANS(4)) RD=NL RE=ONM-RD RE=(ANS(5)-ANS(3))/RE ANS(7)=(ANS(3)/RD)/RE 90 ANS(8)= SQRT(RE) IP=M*(NEW-1)+NEW RD=D(IP) LYP=NEW-M DO 100 J=1,M LYP=LYP+M IF(LL(J)) 100, 94, 97 94 IF(J-NEW) 96, 98, 96 96 IJ=M*(J-1)+J D(IJ)=D(IJ)+D(LYP)*D(LYP)/RD 97 D(LYP)=D(LYP)/RD GO TO 100 98 D(IP)=1.0/RD 100 CONTINUE LYP=LY+NEW B(NL)=D(LYP) IF(NL-1) 112, 112, 105 105 ID=NL-1 DO 110 J=1,ID IJ=NL-J KK=L(IJ) LYP=LY+KK B(IJ)=D(LYP) DO 110 K=1,J IK=NL-K+1 MK=L(IK) LYP=M*(MK-1)+KK 110 B(IJ)=B(IJ)-D(LYP)*B(IK) 112 ANS(9)=XBAR(MY) DO 115 I=1,NL KK=L(I) ANS(9)=ANS(9)-B(I)*XBAR(KK) IJ=M*(KK-1)+KK 114 S(I)=ANS(8)* SQRT(D(IJ)) 115 T(I)=B(I)/S(I) IP=M*(NEW-1) DO 130 I=1,M IJ=I-M IK=NEW-M IP=IP+1 IF(LL(I)) 130, 130, 120 120 DO 126 J=1,M IJ=IJ+M IK=IK+M IF(LL(J)) 126, 122, 122 122 IF(J-NEW) 124, 126, 124 124 D(IJ)=D(IJ)-D(IP)*D(IK) 126 CONTINUE D(IP)=D(IP)/(-RD) 130 CONTINUE RD=N-NSTEP(4) RD=ONM/RD 132 ANS(10)=SQRT(1.0-(1.0-ANS(6)*ANS(6))*RD) 134 ANS(11)=ANS(8)*SQRT(RD) CALL STOUT (NSTEP,ANS,L,B,S,T,NSTOP) IF(NSTOP) 140, 140, 150 140 CONTINUE 150 RETURN END SUBROUTINE SUBMX (A,D,S,NO,NV,N) DIMENSION A(1),D(1),S(1) L=0 LL=0 DO 20 J=1,NV DO 15 I=1,NO L=L+1 IF(S(I)) 15, 15, 10 10 LL=LL+1 D(LL)=A(L) 15 CONTINUE 20 CONTINUE N=0 DO 30 I=1,NO IF(S(I)) 30, 30, 25 25 N=N+1 30 CONTINUE RETURN END SUBROUTINE SUBST(A,C,R,B,S,NO,NV,NC) DIMENSION A(1),C(1),R(1),S(1) DO 9 I=1,NO IQ=I-NO K=-2 DO 8 J=1,NC R(J)=0.0 K=K+3 IZ=C(K) IA=IQ+IZ*NO IGO=C(K+1) Q=A(IA)-C(K+2) GO TO(1,2,3,4,5,6),IGO 1 IF(Q) 7,8,8 2 IF(Q) 7,7,8 3 IF(Q) 8,7,8 4 IF(Q) 7,8,7 5 IF(Q) 8,7,7 6 IF(Q) 8,8,7 7 R(J)=1.0 8 CONTINUE 9 CALL B(R,S(I)) RETURN END SUBROUTINE TAB1(A,S,NOVAR,UBO,FREQ,PCT,STATS,NO,NV) DIMENSION A(1),S(1),UBO(1),FREQ(1),PCT(1),STATS(1) DIMENSION WBO(3) DO 5 I=1,3 5 WBO(I)=UBO(I) VMIN=1.0E33 VMAX=-1.0E33 IJ=NO*(NOVAR-1) DO 30 J=1,NO IJ=IJ+1 IF(S(J)) 10,30,10 10 IF(A(IJ)-VMIN) 15,20,20 15 VMIN=A(IJ) 20 IF(A(IJ)-VMAX) 30,30,25 25 VMAX=A(IJ) 30 CONTINUE STATS(4)=VMIN STATS(5)=VMAX IF(UBO(1)-UBO(3)) 40,35,40 35 UBO(1)=VMIN UBO(3)=VMAX 40 INN=UBO(2) DO 45 I=1,INN FREQ(I)=0.0 45 PCT(I)=0.0 DO 50 I=1,3 50 STATS(I)=0.0 SINT=ABS((UBO(3)-UBO(1))/(UBO(2)-2.0)) SCNT=0.0 IJ=NO*(NOVAR-1) DO 75 J=1,NO IJ=IJ+1 IF(S(J)) 55,75,55 55 SCNT=SCNT+1.0 STATS(1)=STATS(1)+A(IJ) STATS(3)=STATS(3)+A(IJ)*A(IJ) TEMP=UBO(1)-SINT INTX=INN-1 DO 60 I=1,INTX TEMP=TEMP+SINT IF(A(IJ)-TEMP) 70,60,60 60 CONTINUE IF(A(IJ)-TEMP) 75,65,65 65 FREQ(INN)=FREQ(INN)+1.0 GO TO 75 70 FREQ(I)=FREQ(I)+1.0 75 CONTINUE IF (SCNT)79,105,79 79 DO 80 I=1,INN 80 PCT(I)=FREQ(I)*100.0/SCNT IF(SCNT-1.0) 85,85,90 85 STATS(2)=STATS(1) STATS(3)=0.0 GO TO 95 90 STATS(2)=STATS(1)/SCNT STATS(3)=SQRT(ABS((STATS(3)-STATS(1)*STATS(1)/SCNT)/(SCNT-1.0))) 95 DO 100 I=1,3 100 UBO(I)=WBO(I) 105 RETURN END SUBROUTINE TAB2(A,S,NOV,UBO,FREQ,PCT,STAT1,STAT2,NO,NV) DIMENSION A(1),S(1),NOV(2),UBO(3,2),FREQ(1),PCT(1),STAT1(1), 1STAT2(2),SINT(2) DIMENSION WBO(3,2) DO 5 I=1,3 DO 5 J=1,2 5 WBO(I,J)=UBO(I,J) DO 40 I=1,2 IF(UBO(1,I)-UBO(3,I)) 40, 10, 40 10 VMIN=1.0E33 VMAX=-1.0E33 IJ=NO*(NOV(I)-1) DO 35 J=1,NO IJ=IJ+1 IF(S(J)) 15,35,15 15 IF(A(IJ)-VMIN) 20,25,25 20 VMIN=A(IJ) 25 IF(A(IJ)-VMAX) 35,35,30 30 VMAX=A(IJ) 35 CONTINUE UBO(1,I)=VMIN UBO(3,I)=VMAX 40 CONTINUE 45 DO 50 I=1,2 50 SINT(I)=ABS((UBO(3,I)-UBO(1,I))/(UBO(2,I)-2.0)) INT1=UBO(2,1) INT2=UBO(2,2) INTT=INT1*INT2 DO 55 I=1,INTT FREQ(I)=0.0 55 PCT(I)=0.0 INTY=3*INT1 DO 60 I=1,INTY 60 STAT1(I)=0.0 INTZ=3*INT2 DO 65 I=1,INTZ 65 STAT2(I)=0.0 SCNT=0.0 INTY=INT1-1 INTX=INT2-1 IJ=NO*(NOV(1)-1) IJX=NO*(NOV(2)-1) DO 95 J=1,NO IJ=IJ+1 IJX=IJX+1 IF(S(J)) 70,95,70 70 SCNT=SCNT+1.0 TEMP1=UBO(1,1)-SINT(1) DO 75 IY=1,INTY TEMP1=TEMP1+SINT(1) IF(A(IJ)-TEMP1) 80,75,75 75 CONTINUE IY=INT1 80 IYY=3*(IY-1)+1 STAT1(IYY)=STAT1(IYY)+A(IJ) IYY=IYY+1 STAT1(IYY)=STAT1(IYY)+1.0 IYY=IYY+1 STAT1(IYY)=STAT1(IYY)+A(IJ)*A(IJ) TEMP2=UBO(1,2)-SINT(2) DO 85 IX=1,INTX TEMP2=TEMP2+SINT(2) IF(A(IJX)-TEMP2) 90,85,85 85 CONTINUE IX=INT2 90 IJF=INT1*(IX-1)+IY FREQ(IJF)=FREQ(IJF)+1.0 IX=3*(IX-1)+1 STAT2(IX)=STAT2(IX)+A(IJX) IX=IX+1 STAT2(IX)=STAT2(IX)+1.0 IX=IX+1 STAT2(IX)=STAT2(IX)+A(IJX)*A(IJX) 95 CONTINUE IF (SCNT)98,151,98 98 DO 100 I=1,INTT 100 PCT(I)=FREQ(I)*100.0/SCNT IXY=-1 DO 120 I=1,INT1 IXY=IXY+3 ISD=IXY+1 TEMP1=STAT1(IXY) SUM=STAT1(IXY-1) IF(TEMP1-1.0) 120,105,110 105 STAT1(ISD)=0.0 GO TO 115 110 STAT1(ISD)=SQRT(ABS((STAT1(ISD)-SUM*SUM/TEMP1)/(TEMP1-1.0))) 115 STAT1(IXY)=SUM/TEMP1 120 CONTINUE IXX=-1 DO 140 I=1,INT2 IXX=IXX+3 ISD=IXX+1 TEMP2=STAT2(IXX) SUM=STAT2(IXX-1) IF(TEMP2-1.0) 140,125,130 125 STAT2(ISD)=0.0 GO TO 135 130 STAT2(ISD)=SQRT(ABS((STAT2(ISD)-SUM*SUM/TEMP2)/(TEMP2-1.0))) 135 STAT2(IXX)=SUM/TEMP2 140 CONTINUE DO 150 I=1,3 DO 150 J=1,2 150 UBO(I,J)=WBO(I,J) 151 RETURN END SUBROUTINE TALLY(A,S,TOTAL,AVER,SD,VMIN,VMAX,NO,NV) DIMENSION A(1),S(1),TOTAL(1),AVER(1),SD(1),VMIN(1),VMAX(1) IER=0 DO 1 K=1,NV TOTAL(K)=0.0 AVER(K)=1.0E33 SD(K)=1.0E33 VMIN(K)=-1.0E33 1 VMAX(K)=1.0E33 SCNT=0.0 DO 7 J=1,NO IJ=J-NO IF(S(J)) 2,7,2 2 SCNT=SCNT+1.0 DO 6 I=1,NV IJ=IJ+NO TOTAL(I)=TOTAL(I)+A(IJ) IF(A(IJ)-VMIN(I)) 3,4,4 3 VMIN(I)=A(IJ) 4 IF(A(IJ)-VMAX(I)) 6,6,5 5 VMAX(I)=A(IJ) 6 SD(I)=SD(I)+A(IJ)*A(IJ) 7 CONTINUE IF (SCNT)8,8,9 8 IER=1 GO TO 15 9 DO 10 I=1,NV 10 AVER(I)=TOTAL(I)/SCNT IF (SCNT-1.0) 13,11,13 11 IER=2 DO 12 I=1,NV 12 SD(I)=0.0 GO TO 15 13 DO 14 I=1,NV 14 SD(I)=SQRT(ABS((SD(I)-TOTAL(I)*TOTAL(I)/SCNT)/(SCNT-1.0))) 15 RETURN END SUBROUTINE TCNP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+C(2)*B POL(2)=C(2)*A IF(N-2)2,2,4 4 WORK(1)=1. WORK(2)=B WORK(3)=0. WORK(4)=A XD=A+A X0=B+B DO 6 J=3,N P=0. DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0. WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END SUBROUTINE TCSP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 XD=A+A X0=B+B-1. POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 4 WORK(1)=1. WORK(2)=X0 WORK(3)=0. WORK(4)=XD XD=XD+XD X0=X0+X0 DO 6 J=3,N P=0. DO 5 K=2,J H=P-WORK(2*K-3)+X0*WORK(2*K-2) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P POL(K-1)=POL(K-1)+H*C(J) 5 P=XD*P WORK(2*J-1)=0. WORK(2*J)=P 6 POL(J)=C(J)*P RETURN END SUBROUTINE TEAS(X,N,FIN,EPS,IER) DIMENSION X(1) NEW=N IF(NEW-10)1,2,2 1 IER=-1 RETURN 2 ISW1=0 ISW2=0 W1=1.E38 W7=X(4)-X(3) IF(W7)3,4,3 3 W1=1./W7 4 W5=1.E38 W7=X(2)-X(1) IF(W7)5,6,5 5 W5=1./W7 6 W4=X(3)-X(2) IF(W4)9,7,9 7 W4=1.E38 T=X(2) W2=X(3) 8 W3=1.E38 GO TO 17 9 W4=1./W4 T=1.E38 W7=W4-W5 IF(W7)10,11,10 10 T=X(2)+1./W7 11 W2=W1-W4 IF(W2)15,12,15 12 W2=1.E38 IF(T-1.E38)13,14,14 13 ISW2=1 14 W3=W4 GO TO 17 15 W2=X(3)+1./W2 W7=W2-T IF(W7)16,8,16 16 W3=W4+1./W7 17 ISW1=ISW2 ISW2=0 IMIN=4 DO 40 I=5,NEW IAUS=I-IMIN W4=1.E38 W5=X(I-1) W7=X(I)-X(I-1) IF(W7)18,24,18 18 W4=1./W7 IF(W1-1.E38)19,25,25 19 W6=W4-W1 IF(ABS(W6)-ABS(W4)*1.E-4)20,20,22 20 ISW2=1 IF(W6)22,21,22 21 W5=1.E38 W6=W1 IF(W2-1.E38)28,26,26 22 W5=X(I-1)+1./W6 IF(ABS(W5)-ABS(X(I-1))*1.E-5)23,24,24 23 IF(W5)36,24,36 24 W7=W5-W2 IF(W7)27,25,27 25 W6=1.E38 26 ISW2=0 X(IAUS)=W2 GO TO 37 27 W6=W1+1./W7 28 IF(ISW1-1)33,29,29 29 IF(W2-1.E38)30,32,32 30 W7=W5/(W2-W5)+T/(W2-T)+X(I-2)/(X(I-2)-W2) IF(1.+W7)31,38,31 31 X(IAUS)=W7*W2/(1.+W7) GO TO 39 32 X(IAUS)=W5+T-X(I-2) GO TO 39 33 W7=W6-W3 IF(W7)34,38,34 34 X(IAUS)=W2+1./W7 IF(ABS(X(IAUS))-ABS(W2)*1.E-5)35,37,37 35 IF(X(IAUS))36,37,36 36 NEW=IAUS-1 ISW2=0 GO TO 41 37 IF(W2-1.E38)39,38,38 38 X(IAUS)=1.E38 IMIN=I 39 W1=W4 T=W2 W2=W5 W3=W6 ISW1=ISW2 40 ISW2=0 NEW=NEW-IMIN 41 IEND=NEW-1 DO 47 I=1,IEND W1=ABS(X(I)-X(I+1)) W2=ABS(X(I+1)) IF(W1-EPS)44,44,42 42 IF(W2-1.)46,46,43 43 IF(W1-EPS*W2)44,44,46 44 ISW2=ISW2+1 IF(3-ISW2)45,45,47 45 FIN=X(I) IER=0 RETURN 46 ISW2=0 47 CONTINUE IF(NEW-6)48,2,2 48 FIN=X(NEW) IER=1 RETURN END SUBROUTINE TETRA (N,U,V,HU,HV,R,RS,IE) DIMENSION XCOF(8),COF(8),ROOTR(7),ROOTI(7) DIMENSION U(1),V(1) DOUBLE PRECISION X31,X32,X312,X322 A=0.0 B=0.0 C=0.0 D=0.0 DO 40 I=1,N IF(U(I)-HU) 10, 25, 25 10 IF(V(I)-HV) 15, 20, 20 15 D=D+1.0 GO TO 40 20 B=B+1.0 GO TO 40 25 IF(V(I)-HV) 30, 35, 35 30 C=C+1.0 GO TO 40 35 A=A+1.0 40 CONTINUE IE=0 IF(A) 60, 60, 45 45 IF(B) 60, 60, 50 50 IF(C) 60, 60, 55 55 IF(D) 60, 60, 70 60 IE=1 GO TO 86 70 FN=N P1=(A+C)/FN Q1=(B+D)/FN P2=(A+B)/FN Q2=(C+D)/FN CALL NDTRI (Q1,X1,Y1,ER) CALL NDTRI (Q2,X2,Y2,ER) IF(X1) 76, 72, 76 72 IF(X2) 76, 74, 76 74 R=0.0 GO TO 90 76 XCOF(1)=-((A*D-B*C)/(Y1*Y2*FN*FN)) XCOF(2)=1.0 XCOF(3)=X1*X2/2.0 XCOF(4)=(X1*X1-1.0)*(X2*X2-1.0)/6.0 X31=DBLE(X1) X32=DBLE(X2) X312=X31**2 X322=X32**2 XCOF(5)=SNGL(X31*(X312-3.0D0)*X32*(X322-3.0D0)/24.0D0) XCOF(6)=SNGL((X312*(X312-6.0D0)+3.0D0)*(X322*(X322-6.0D0)+3.0D0) 1 /120.0D0) XCOF(7)=SNGL(X31*(X312*(X312-10.0D0)+15.0D0)*X32*(X322*(X322-10.0 1 D0)+15.0D0)/720.0D0) XCOF(8)=SNGL((((X312-15.0D0)*X312+45.0D0)*X312-15.0D0)*(((X322- 1 15.0D0)*X322+45.0D0)*X322-15.0D0)/5040.0D0) CALL POLRT (XCOF,COF,7,ROOTR,ROOTI,IER) J=0 IF(IER) 78, 78, 84 78 DO 82 I=1,7 IF(ABS(ROOTI(I))-.5*ABS(ROOTR(I))*1.0E-6)79,79,82 79 R=ROOTR(I) IF(ABS(R)-1.0)81,81,80 80 R=1.E33 GO TO 82 81 J=J+1 82 CONTINUE IF(J-1)83,88,83 83 IE=2 GO TO 86 84 IE=IER 86 R=1.0E33 RS=R GO TO 100 88 IF(R-1.0E33)90,83,83 90 RS= SQRT(P1*P2*Q1*Q2)/(Y1*Y2* SQRT(FN)) 100 RETURN END SUBROUTINE TEUL (FCT,SUM,MAX,EPS,IER) DIMENSION Y(15) IF(MAX)1,1,2 1 IER=-1 GOTO 12 2 IER=1 I=1 M=1 N=1 Y(1)=FCT(N) SUM=Y(1)*.5 3 J=0 4 I=I+1 IF(I-MAX)5,5,12 5 N=I AMN=FCT(N) DO 6 K=1,M AMP=(AMN+Y(K))*.5 Y(K)=AMN 6 AMN=AMP IF(ABS(AMN)-ABS(Y(M)))7,9,9 7 IF(M-15)8,9,9 8 M=M+1 Y(M)=AMN AMN=.5*AMN 9 SUM=SUM+AMN IF(ABS(AMN)-EPS*ABS(SUM))10,10,3 10 J=J+1 IF(J-5)4,11,11 11 IER=0 12 RETURN END SUBROUTINE THEP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 XD=A+A X0=B+B POL(1)=C(1)+C(2)*X0 POL(2)=C(2)*XD IF(N-2)2,2,4 4 WORK(1)=1. WORK(2)=X0 WORK(3)=0. WORK(4)=XD FI=2. DO 6 J=3,N P=0. DO 5 K=2,J H=P*XD+WORK(2*K-2)*X0-FI*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=P*XD FI=FI+2. 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE TIE(R,N,KT,T) DIMENSION R(1) T=0.0 Y=0.0 5 X=1.0E38 IND=0 DO 30 I=1,N IF(R(I)-Y) 30,30,10 10 IF(R(I)-X) 20,30,30 20 X=R(I) IND=IND+1 30 CONTINUE IF(IND) 90,90,40 40 Y=X CT=0.0 DO 60 I=1,N IF(R(I)-X) 60,50,60 50 CT=CT+1.0 60 CONTINUE IF(CT) 70,5,70 70 IF(KT-1) 75,80,75 75 T=T+CT*(CT-1.)/2.0 GO TO 5 80 T=T+(CT*CT*CT-CT)/12.0 GO TO 5 90 RETURN END SUBROUTINE TLAP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+C(2)-B*C(2) POL(2)=-C(2)*A IF(N-2)2,2,4 4 WORK(1)=1. WORK(2)=1.D0-B WORK(3)=0. WORK(4)=-A FI=1. DO 6 J=3,N FI=FI+1. Q=1./FI Q1=Q-1. Q2=1.-Q1-B*Q Q=Q*A P=0. DO 5 K=2,J H=-P*Q+WORK(2*K-2)*Q2+WORK(2*K-3)*Q1 P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=-Q*P 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE TLEP(A,B,POL,N,C,WORK) DIMENSION POL(1),C(1),WORK(1) IF(N-1)2,1,3 1 POL(1)=C(1) 2 RETURN 3 POL(1)=C(1)+B*C(2) POL(2)=A*C(2) IF(N-2)2,2,4 4 WORK(1)=1. WORK(2)=B WORK(3)=0. WORK(4)=A FI=1. DO 6 J=3,N FI=FI+1. Q=1./FI-1. Q1=1.-Q P=0. DO 5 K=2,J H=(A*P+B*WORK(2*K-2))*Q1+Q*WORK(2*K-3) P=WORK(2*K-2) WORK(2*K-2)=H WORK(2*K-3)=P 5 POL(K-1)=POL(K-1)+H*C(J) WORK(2*J-1)=0. WORK(2*J)=A*P*Q1 6 POL(J)=C(J)*WORK(2*J) RETURN END SUBROUTINE TPRD(A,B,R,N,M,MSA,MSB,L) DIMENSION A(1),B(1),R(1) MS=MSA*10+MSB IF(MS-22) 30,10,30 10 DO 20 I=1,N 20 R(I)=A(I)*B(I) RETURN 30 IR=1 DO 90 K=1,L DO 90 J=1,M R(IR)=0.0 DO 80 I=1,N IF(MS) 40,60,40 40 CALL LOC(I,J,IA,N,M,MSA) CALL LOC(I,K,IB,N,L,MSB) IF(IA) 50,80,50 50 IF(IB) 70,80,70 60 IA=N*(J-1)+I IB=N*(K-1)+I 70 R(IR)=R(IR)+A(IA)*B(IB) 80 CONTINUE 90 IR=IR+1 RETURN END SUBROUTINE TRACE (M,R,CON,K,D) DIMENSION R(1),D(1) FM=M L=0 DO 100 I=1,M L=L+I 100 D(I)=R(L) K=0 DO 110 I=1,M IF(D(I)-CON) 120, 105, 105 105 K=K+1 110 D(I)=D(I)/FM 120 DO 130 I=2,K 130 D(I)=D(I)+D(I-1) RETURN END SUBROUTINE TTEST (A,NA,B,NB,NOP,NDF,ANS) DIMENSION A(1),B(1) NDF=0 ANS=0.0 AMEAN=0.0 DO 110 I=1,NA 110 AMEAN=AMEAN+A(I) FNA=NA AMEAN=AMEAN/FNA 115 BMEAN=0.0 DO 120 I=1,NB 120 BMEAN=BMEAN+B(I) FNB=NB BMEAN=BMEAN/FNB IF(NOP-4) 122, 180, 200 122 IF(NOP-1) 200, 135, 125 125 SA2=0.0 DO 130 I=1,NA 130 SA2=SA2+(A(I)-AMEAN)**2 SA2=SA2/(FNA-1.0) 135 SB2=0.0 DO 140 I=1,NB 140 SB2=SB2+(B(I)-BMEAN)**2 SB2=SB2/(FNB-1.0) GO TO (150,160,170), NOP 150 ANS=((BMEAN-AMEAN)/SQRT(SB2))*SQRT(FNB) NDF=NB-1 GO TO 200 160 NDF=NA+NB-2 FNDF=NDF S=SQRT(((FNA-1.0)*SA2+(FNB-1.0)*SB2)/FNDF) ANS=((BMEAN-AMEAN)/S)*(1.0/SQRT(1.0/FNA+1.0/FNB)) GO TO 200 170 ANS=(BMEAN-AMEAN)/SQRT(SA2/FNA+SB2/FNB) A1=(SA2/FNA+SB2/FNB)**2 A2=(SA2/FNA)**2/(FNA+1.0)+(SB2/FNB)**2/(FNB+1.0) NDF=A1/A2-2.0+0.5 GO TO 200 180 SD=0.0 D=BMEAN-AMEAN DO 190 I=1,NB 190 SD=SD+(B(I)-A(I)-D)**2 SD=SQRT(SD/(FNB-1.0)) ANS=(D/SD)*SQRT(FNB) NDF=NB-1 200 RETURN END SUBROUTINE TWOAV (A,R,N,M,W,XR,NDF,NR) DIMENSION A(1),R(1),W(1) IF(NR-1) 10, 30, 10 10 DO 20 I=1,N IJ=I-N IK=IJ DO 15 J=1,M IJ=IJ+N 15 W(J)=A(IJ) CALL RANK (W,W(M+1),M) DO 20 J=1,M IK=IK+N IW=M+J 20 R(IK)=W(IW) GO TO 35 30 NM=N*M DO 32 I=1,NM 32 R(I)=A(I) 35 RTSQ=0.0 IR=0 DO 50 J=1,M RT=0.0 DO 40 I=1,N IR=IR+1 40 RT=RT+R(IR) 50 RTSQ=RTSQ+RT*RT FNM=N*(M+1) FM=M XR=(12.0/(FM*FNM))*RTSQ-3.0*FNM NDF=M-1 RETURN END SUBROUTINE UTEST(A,R,N1,N2,U,Z) DIMENSION A(1),R(1) N=N1+N2 CALL RANK(A,R,N) Z=0.0 R2=0.0 NP=N1+1 DO 10 I=NP,N 10 R2=R2+R(I) FNX=N1*N2 FN=N FN2=N2 UP=FNX+FN2*((FN2+1.0)/2.0)-R2 U=FNX-UP IF(UP-U) 20,30,30 20 U=UP 30 IF(N2-20) 80,40,40 40 KT=1 CALL TIE(R,N,KT,TS) IF(TS) 50,60,50 50 IF (TS-(FN*FN*FN-FN)/12)52,51,52 51 IER=1 GO TO 80 52 S=SQRT((FNX/(FN*(FN-1.0)))*(((FN*FN*FN-FN)/12.0)-TS)) GO TO 70 60 S=SQRT(FNX*(FN+1.0)/12.0) 70 Z=(U-FNX*0.5)/S 80 RETURN END SUBROUTINE VARMX (M,K,A,NC,TV,H,F,D,IER) DIMENSION A(1),TV(1),H(1),F(1),D(1) IER=0 EPS=0.00116 TVLT=0.0 LL=K-1 NV=1 NC=0 FN=M FFN=FN*FN CONS=0.7071066 DO 110 I=1,M H(I)=0.0 DO 110 J=1,K L=M*(J-1)+I 110 H(I)=H(I)+A(L)*A(L) DO 120 I=1,M 115 H(I)= SQRT(H(I)) DO 120 J=1,K L=M*(J-1)+I 120 A(L)=A(L)/H(I) GO TO 132 130 NV=NV+1 TVLT=TV(NV-1) 132 TV(NV)=0.0 DO 150 J=1,K AA=0.0 BB=0.0 LB=M*(J-1) DO 140 I=1,M L=LB+I CC=A(L)*A(L) AA=AA+CC 140 BB=BB+CC*CC 150 TV(NV)=TV(NV)+(FN*BB-AA*AA)/FFN IF(NV-51)160,155,155 155 IER=1 GO TO 430 160 IF((TV(NV)-TVLT)-(1.E-7)) 170, 170, 190 170 NC=NC+1 IF(NC-3) 190, 190, 430 190 DO 420 J=1,LL L1=M*(J-1) II=J+1 DO 420 K1=II,K L2=M*(K1-1) AA=0.0 BB=0.0 CC=0.0 DD=0.0 DO 230 I=1,M L3=L1+I L4=L2+I U=(A(L3)+A(L4))*(A(L3)-A(L4)) T=A(L3)*A(L4) T=T+T CC=CC+(U+T)*(U-T) DD=DD+2.0*U*T AA=AA+U 230 BB=BB+T T=DD-2.0*AA*BB/FN B=CC-(AA*AA-BB*BB)/FN IF(T-B) 280, 240, 320 240 IF((T+B)-EPS) 420, 250, 250 250 COS4T=CONS SIN4T=CONS GO TO 350 280 TAN4T= ABS(T)/ ABS(B) IF(TAN4T-EPS) 300, 290, 290 290 COS4T=1.0/ SQRT(1.0+TAN4T*TAN4T) SIN4T=TAN4T*COS4T GO TO 350 300 IF(B) 310, 420, 420 310 SINP=CONS COSP=CONS GO TO 400 320 CTN4T= ABS(T/B) IF(CTN4T-EPS) 340, 330, 330 330 SIN4T=1.0/ SQRT(1.0+CTN4T*CTN4T) COS4T=CTN4T*SIN4T GO TO 350 340 COS4T=0.0 SIN4T=1.0 350 COS2T= SQRT((1.0+COS4T)/2.0) SIN2T=SIN4T/(2.0*COS2T) 355 COST= SQRT((1.0+COS2T)/2.0) SINT=SIN2T/(2.0*COST) IF(B) 370, 370, 360 360 COSP=COST SINP=SINT GO TO 380 370 COSP=CONS*COST+CONS*SINT 375 SINP= ABS(CONS*COST-CONS*SINT) 380 IF(T) 390, 390, 400 390 SINP=-SINP 400 DO 410 I=1,M L3=L1+I L4=L2+I AA=A(L3)*COSP+A(L4)*SINP A(L4)=-A(L3)*SINP+A(L4)*COSP 410 A(L3)=AA 420 CONTINUE GO TO 130 430 DO 440 I=1,M DO 440 J=1,K L=M*(J-1)+I 440 A(L)=A(L)*H(I) NC=NV-1 DO 450 I=1,M 450 H(I)=H(I)*H(I) DO 470 I=1,M F(I)=0.0 DO 460 J=1,K L=M*(J-1)+I 460 F(I)=F(I)+A(L)*A(L) 470 D(I)=H(I)-F(I) RETURN END SUBROUTINE WTEST (A,R,N,M,WA,W,CS,NDF,NR) DIMENSION A(1),R(1),WA(1) FM=M FN=N T=0.0 KT=1 DO 20 I=1,N IJ=I-N IK=IJ IF(NR-1) 5,2,5 2 DO 3 J=1,M IJ=IJ+N K=M+J 3 WA(K)=A(IJ) GO TO 15 5 DO 10 J=1,M IJ=IJ+N 10 WA(J)=A(IJ) CALL RANK(WA,WA(M+1),M) 15 CALL TIE(WA(M+1),M,KT,TI) T=T+TI DO 20 J=1,M IK=IK+N IW=M+J 20 R(IK)=WA(IW) IR=0 DO 40 J=1,M WA(J)=0.0 DO 40 I=1,N IR=IR+1 40 WA(J)=WA(J)+R(IR) SM=0.0 DO 50 J=1,M 50 SM=SM+WA(J) SM=SM/FM S=0.0 DO 60 J=1,M 60 S=S+(WA(J)-SM)*(WA(J)-SM) W=S/(((FN*FN)*(FM*FM*FM-FM)/12.0)-FN*T) CS=0.0 NDF=0 IF(M-7) 70,70,65 65 CS=FN*(FM-1.0)*W NDF=M-1 70 RETURN END SUBROUTINE XCPY(A,R,L,K,NR,MR,NA,MA,MS) DIMENSION A(1),R(1) IR=0 L2=L+NR-1 K2=K+MR-1 DO 5 J=K,K2 DO 5 I=L,L2 IR=IR+1 R(IR)=0.0 CALL LOC(I,J,IA,NA,MA,MS) IF(IA) 4,5,4 4 R(IR)=A(IA) 5 CONTINUE RETURN END