24 F(I,J)=F(I,J)/DF(I) 241 CONTINUE ENDIF
30 CONTINUE RETURN END
SUBROUTINE FORMA(N,M,MNH,F,A) C THIS SUBROUTINE FORMS A BY F DIMENSION F(N,M),A(MNH,MNH) IF(M-N) 40,50,50 40 DO 44 I=1,MNH DO 44 J=I,MNH A(I,J)=0.0 DO 42 IS=1,N
42 A(I,J)=A(I,J)+F(IS,I)*F(IS,J) A(J,I)=A(I,J) 44 CONTINUE RETURN
50 DO 54 I=1,MNH DO 54 J=I,MNH A(I,J)=0.0 DO 52 JS=1,M
52 A(I,J)=A(I,J)+F(I,JS)*F(J,JS) A(J,I)=A(I,J) 54 CONTINUE RETURN END
SUBROUTINE JCB(N,A,S,EPS)
C THIS SUBROUTINE COMPUTS EIGENVALUES AND EIGENVECTORS OF A DIMENSION A(N,N),S(N,N) DO 30 I=1,N DO 30 J=1,I IF(I-J) 20,10,20 10 S(I,J)=1. GO TO 30 20 S(I,J)=0. S(J,I)=0. 30 CONTINUE G=0.
DO 40 I=2,N
I1=I-1
DO 40 J=1,I1
40 G=G+2.*A(I,J)*A(I,J) S1=SQRT(G)
S2=EPS/FLOAT(N)*S1 S3=S1 L=0
50 S3=S3/FLOAT(N) 60 DO 130 IQ=2,N IQ1=IQ-1
DO 130 IP=1,IQ1
IF(ABS(A(IP,IQ)).LT.S3) GOTO 130 L=1
V1=A(IP,IP) V2=A(IP,IQ) V3=A(IQ,IQ) U=0.5*(V1-V3) IF(U.EQ.0.0) G=1.
IF(ABS(U).GE.1E-10) G=-SIGN(1.,U)*V2/SQRT(V2*V2+U*U) ST=G/SQRT(2.*(1.+SQRT(1.-G*G))) CT=SQRT(1.-ST*ST) DO 110 I=1,N
G=A(I,IP)*CT-A(I,IQ)*ST
A(I,IQ)=A(I,IP)*ST+A(I,IQ)*CT A(I,IP)=G
G=S(I,IP)*CT-S(I,IQ)*ST
S(I,IQ)=S(I,IP)*ST+S(I,IQ)*CT 110 S(I,IP)=G
DO 120 I=1,N A(IP,I)=A(I,IP) 120 A(IQ,I)=A(I,IQ) G=2.*V2*ST*CT
A(IP,IP)=V1*CT*CT+V3*ST*ST-G A(IQ,IQ)=V1*ST*ST+V3*CT*CT+G
A(IP,IQ)=(V1-V3)*ST*CT+V2*(CT*CT-ST*ST) A(IQ,IP)=A(IP,IQ) 130 CONTINUE
IF(L-1) 150,140,150 140 L=0
GO TO 60
150 IF(S3.GT.S2) GOTO 50 RETURN END
SUBROUTINE ARRANG(KV,MNH,A,ER,S)
C THIS SUBROUTINE PROVIDES A SERIES OF EIGENVALUES C FROM MAX TO MIN
DIMENSION A(MNH,MNH),ER(mnh,4),S(MNH,MNH) TR=0.0
DO 200 I=1,MNH TR=TR+A(I,I) 200 ER(I,1)=A(I,I) MNH1=MNH-1
DO 210 K1=MNH1,1,-1 DO 210 K2=K1,MNH1
IF(ER(K2,1).LT.ER(K2+1,1)) THEN C=ER(K2+1,1)
ER(K2+1,1)=ER(K2,1) ER(K2,1)=C
DO 205 I=1,MNH C=S(I,K2+1)
S(I,K2+1)=S(I,K2) S(I,K2)=C 205 CONTINUE ENDIF 210 CONTINUE
ER(1,2)=ER(1,1) DO 220 I=2,KV
ER(I,2)=ER(I-1,2)+ER(I,1) 220 CONTINUE DO 230 I=1,KV ER(I,3)=ER(I,1)/TR ER(I,4)=ER(I,2)/TR 230 CONTINUE
WRITE(6,250) TR
250 FORMAT(/5X,'TOTAL SQUARE ERROR=',F20.5) RETURN END
SUBROUTINE TCOEFF(KVT,KV,N,M,MNH,S,F,V,evf,tcf,ER)
C THIS SUBROUTINE PROVIDES STANDARD EIGENVECTORS (M.GE.N,SAVED IN S;
C M.LT.N,SAVED IN F) AND ITS TIME COEFFICENTS SERIES (M.GE.N, C SAVED IN F; M.LT.N,SAVED IN S)
DIMENSION S(MNH,MNH),F(N,M),V(MNH),ER(mnh,4),evf(n,kvt),tcf(m,kvt) DO 360 J=1,KVT
C=0.
DO 350 I=1,MNH 350 C=C+S(I,J)*S(I,J) C=SQRT(C)
DO 160 I=1,MNH s(I,J)=S(I,J)/C 160 evf(I,J)=S(I,J)/C 360 CONTINUE
cccccccccccccccccccccccccccccccccccccccccc c t=0.0
c do 365 i=1,mnh c365 t=t+s(i,1)*s(i,2) c write(*,*)t
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc IF(N.LE.M) THEN DO 390 J=1,M DO 370 I=1,N V(I)=F(I,J) F(I,J)=0. 370 CONTINUE do 371 is=1,kvt tcf(j,is)=0. 371 continue
DO 380 IS=1,KVT DO 380 I=1,N
f(is,j)=F(IS,J)+V(I)*S(I,IS) 380 tcf(j,is)=tcf(J,is)+V(I)*S(I,IS) 390 CONTINUE
ccccccccccccccccccccccccccccccccccccccccccccccccccccc ELSE
DO 410 I=1,N DO 400 J=1,M V(J)=F(I,J) F(I,J)=0. 400 CONTINUE
DO 410 JS=1,KVT DO 410 J=1,M
f(I,JS)=F(I,JS)+V(J)*S(J,JS) 410 CONTINUE
DO 430 JS=1,KVT DO 420 J=1,M
tcf(J,JS)=S(J,JS)*SQRT(ER(JS,1)) 420 CONTINUE DO 430 I=1,N
evf(I,JS)=F(I,JS)/SQRT(ER(JS,1)) 430 CONTINUE t=0.0
do 3650 i=1,m
3650 t=t+tcf(i,1)*tcf(i,2) write(*,*)t t=0.0
do 3651 i=1,n
3651 t=t+evf(i,1)*evf(i,2) write(*,*)t ENDIF RETURN END
SUBROUTINE test3(N1,ff,nf,evf,kvt) c this subroutine sent undefine value ff to evf dimension nf(n1),evf(n1,kvt) do i=1,n1
if(nf(i).ne.0)then do k=1,kvt evf(i,k)=ff enddo endif enddo return end
SUBROUTINE OUTER(KV,ER,mnh)
C THIS SUBROUTINE PRINTS ARRAY ER
C ER(KV,1) FOR SEQUENCE OF EIGENVALUE FROM BIG TO SMALL C ER(KV,2) FOR EIGENVALUE FROM BIG TO SMALL
C ER(KV,3) FOR SMALL LO=(LAMDA/TOTAL VARIANCE) C ER(KV,4) FOR BIG LO=SUM OF SMALL LO) DIMENSION ER(mnh,4) WRITE(16,510)
510 FORMAT(/30X,'EIGENVALUE AND ANALYSIS ERROR',/) WRITE(16,520)
520 FORMAT(10X,1HH,8X,5HLAMDA,10X,6HSLAMDA,11X,2HPH,12X,3HSPH) WRITE(16,530) (IS,(ER(IS,J),J=1,4),IS=1,KV) 530 FORMAT(1X,I10,4F15.5) WRITE(16,540) 540 FORMAT(//) RETURN
百度搜索“77cn”或“免费范文网”即可找到本站免费阅读全部范文。收藏本站方便下次阅读，免费范文网，提供经典小说综合文库实习一(5)在线全文阅读。
相关推荐：