| 查看: 1807 | 回复: 5 | |||
| 当前只显示满足指定条件的回帖，点击这里查看本话题的所有回帖 | |||
涂代洋铁虫 (初入文坛)
|
[交流]
fortran的66阶矩阵对角化
|
||
|
这是一个66阶矩阵，但是我对角化是错误的！请各位大神查看哈！ program MAIN integer::N parameter(N=66) real*8 Hso,B,A,D,S,s6j,I,J,K,Y,X,P dimension B(N),A(N,N),D(N),S(N,N),Hso(N,N) CHARACTER*16 C(N) do i=1,N do j=1,N Hso(i,j)=0.d0 end do end do do i=1,6 Hso(i,i)=2 end do do i=7,14 Hso(i,i)=3 end do do i=15,24 Hso(i,i)=4 end do do i=25,36 Hso(i,i)=5 end do do i=37,50 Hso(i,i)=6 end do do i=51,66 Hso(i,i)=7 end dO do i=1, 66 do j=1, 66 A(i,j) = Hso(i,j) enddo enddo CALL JCB(N,A,S,1E-16) DO 30 I=1,N B(I)=A(I,I) 30 CONTINUE DO 40 J=1,N-1 P=J DO 50 I=J+1,N IF (B(I)<B(P))THEN P=I ENDIF 50 CONTINUE K=B(J) B(J)=B(P) B(P)=K 40 CONTINUE OPEN(2,FILE=\'E.DAT\',STATUS=\'NEW\') DO 60 I=1,N WRITE(2,200)I,B(I)-A(1,1) 60 CONTINUE OPEN(4,FILE=\'FS.DAT\',STATUS=\'OLD\') DO 110 I=1,N READ(4,300)C(I) 110 CONTINUE OPEN(7,FILE=\'VE.DAT\',STATUS=\'NEW\') DO 70 I=1,N DO 80 J=1,N IF(A(J,J).EQ.B(I))THEN WRITE(7,200)I,B(I)-A(1,1) DO 130 X=1,N D(X)=S(X,J) 130 CONTINUE DO 140 Y=1,N-1 P=Y DO 150 Z=Y+1,N IF (ABS(D(Z)).GT.ABS(D(P)))THEN P=Z ENDIF 150 CONTINUE K=D(Y) D(Y)=D(P) D(P)=K 140 CONTINUE P=1 DO 160 M=1,N DO 170 F=1,N IF(D(M).EQ.S(F,J).AND.D(M).NE.0)THEN WRITE(7,400)S(F,J),C(F) ELSEIF(D(M).EQ.S(M,J).AND.D(M).EQ.0)THEN WRITE(7,400)S(M,J),C(M) EXIT ELSEIF(D(M).EQ.0.AND.S(M,J).NE.0)THEN WRITE(7,400)D(M),C(P) P=P+1 EXIT ENDIF 170 CONTINUE 160 CONTINUE ENDIF 80 CONTINUE 70 CONTINUE 100 FORMAT(F25.16) 200 FORMAT(I4," ",F25.16) 300 FORMAT(A16) 400 FORMAT(F25.16," ",A16) CLOSE(4) CLOSE(2) CLOSE(7) stop end SUBROUTINE JCB(N,A,S,EPS) real*8 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.d0 GOTO 30 20 S(I,J)=0.d0 S(J,I)=0.d0 30 CONTINUE G=0.d0 DO 40 I=2,N I1=I-1 DO 40 J=1,I1 40 G=G+2.d0*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 !PRINT*,\'^^^^^^^^^^^^^^^^^^^^^^^^^^^^\' IF(ABS(A(IP,IQ)).LT.S3) GOTO 130 L=1 V1=A(IP,IP) V2=A(IP,IQ) V3=A(IQ,IQ) U=.5*(V1-V3) IF(U.EQ.0.) G=1.d0 IF(ABS(U).GE.1d-10) G=-SIGN(1.d0,U)*V2/SQRT(V2*V2+U*U) ST=G/SQRT(2.d0*(1.d0+SQRT(1.d0-G*G))) CT=SQRT(1.d0-ST*ST) DO 110 I=1,N G=A(I,IP)*CT-A(I,IQ)*ST !PRINT*,\'^^^^^^^^^^^^^^^^^^^^^^^^^^^^\' 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.d0*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 GOTO 60 150 IF(S3.GT.S2) GOTO 50 RETURN END 请各位大神帮帮嘛！ |
回复此楼» 猜你喜欢
274求调剂
已经有20人回复
-
265求调剂
已经有16人回复
-
材料与化工304求B区调剂
已经有6人回复
-
321求调剂
已经有5人回复
-
085600材料与化工306
已经有7人回复
-
085602化学工程求调剂。
已经有4人回复
-
312求调剂
已经有10人回复
-
材料考研求调剂
已经有6人回复
-
调剂推荐
已经有5人回复
-
中国科学院深圳先进技术研究院-光纤传感课题组招生-中国科学院大学、深圳理工大学联培
已经有4人回复
» 本主题相关价值贴推荐，对您同样有帮助:
- 【分享】2009年注册环保工程师基础考试大纲
已经有11人回复
涂代洋
铁虫 (初入文坛)
- 应助: 0 (幼儿园)
- 金币: 5.3
- 散金: 20
- 帖子: 24
- 在线: 3.9小时
- 虫号: 2977137
- 注册: 2014-02-19
- 专业: 凝聚态物性 II ：电子结构
4楼2016-07-16 10:38:42
sciencejoy
新虫 (著名写手)
- 应助: 436 (硕士)
- 金币: 11207.1
- 红花: 90
- 帖子: 2974
- 在线: 498小时
- 虫号: 802149
- 注册: 2009-07-02
- 性别: GG
- 专业: 高分子物理与高分子物理化
2楼2016-07-15 09:55:33
argo
铁杆木虫 (著名写手)
上善若水
- 应助: 4 (幼儿园)
- 金币: 9672.8
- 散金: 200
- 红花: 34
- 帖子: 1940
- 在线: 486.4小时
- 虫号: 507533
- 注册: 2008-02-19
- 性别: GG
- 专业: 凝聚态物性 II ：电子结构
3楼2016-07-15 18:52:38
涂代洋
铁虫 (初入文坛)
- 应助: 0 (幼儿园)
- 金币: 5.3
- 散金: 20
- 帖子: 24
- 在线: 3.9小时
- 虫号: 2977137
- 注册: 2014-02-19
- 专业: 凝聚态物性 II ：电子结构
5楼2016-07-16 11:09:31
