版块导航: 正在加载中...

登录注册

应《网络安全法》要求，自2017年10月1日起，未进行实名认证将不得使用互联网跟帖服务。为保障您的帐号能够正常使用，请尽快对帐号进行手机号验证，感谢您的理解与支持！

24小时热门版块排行榜

返回列表

当前只显示满足指定条件的回帖，点击这里查看本话题的所有回帖

涂代洋

铁虫 (初入文坛)

应助: 0 (幼儿园)
金币: 5.3
散金: 20
帖子: 24
在线: 3.9小时
虫号: 2977137
注册: 2014-02-19
专业: 凝聚态物性 II ：电子结构

[求助] fortran编程超出边界问题

program MAIN

real*8 Hso,B,A,D,S,s6j,I,J,K,Y,X,P,N
parameter(N=66)
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

write(*,*)"Hso"

do i=1,6
   Hso(i,i)=((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,2.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
end do
do i=7,14
   Hso(i,i)=-((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,3.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
end do
do i=15,24
   Hso(i,i)=((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,4.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
   end do
do i=25,36
   Hso(i,i)=-((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,5.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
   end do
do i=37,50
   Hso(i,i)=((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,6.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
   end do
do i=51,66
   Hso(i,i)=-((3.d0*4.d0*7.d0)**(1.0d0/2.0d0))
   *    *s6j(5.0,2.5,7.5,2.5,5.0,1.0)
   *    *(39.d0**(1.0d0/2.0d0))*0.5d0
   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

Function s6j(j1, j2, j3, l1, l2, l3)
   Real :: j1, j2, j3, l1, l2, l3, i, k,n, k1, k2,plus_p1,plus_sum
   real*8 s6j,p1
k1 = max(j1+j2+j3, j1+l2+l3, l1+j2+l3,l1+l2+l3)
   k2 = min(j1+j2+l1+l2, j2+j3+l2+l3, j3+j1+l3+l1)
plus_sum = 0
   Do k = k1, k2, 1
If (k-j1-j2-j3<0.or.abs(k-j1-j2-j3-int(k-j1-j2-j3))>0.0001.or.
   *k-j1-l2-l3<0.or.abs(k-j1-l2-l3-int(k-j1-l2-l3))>0.0001.or.
   *k-l1-j2-l3<0.or.abs(k-l1-j2-l3-int(k-l1-j2-l3))>0.0001.or.
   *k-l1-l2-j3<0.or.abs(k-l1-l2-j3-int(k-l1-l2-j3))>0.0001.or.
   *j1+j2+l1+l2-k<0.or.abs(j1+j2+l1+l2-k-int(j1+j2+l1+l2-k))>0.001.or.
   *j2+j3+l2+l3-k<0.or.abs(j2+j3+l2+l3-k-int(j2+j3+l2+l3-k))>0.001.or.
   *j3+j1+l3+l1-k<0.or.abs(j3+j1+l3+l1-k-int(j3+j1+l3+l1-k))>0.01)Then
plus_p1 =0
Else
plus_p1 = (((-1)**(k))*p1(k+1))/(p1(k-j1-j2-j3)*
   *p1(k-j1-l2-l3)*p1(k-l1-j2-l3)*p1(k-l1-l2-j3)*
   *p1(j1+j2+l1+l2-k)*p1(j2+j3+l2+l3-k)*p1(j3+j1+l3+l1-k))
   plus_sum = plus_sum + plus_p1
End If
   End Do
If (j1+j2-j3<0.or.abs(j1+j2-j3-int(j1+j2-j3))>0.0001.or.
   *j1-j2+j3<0.or.abs(j1-j2+j3-int(j1-j2+j3))>0.0001.or.-j1+j2+j3<0
   *.or.abs(-j1+j2+j3-int(-j1+j2+j3))>0.0001.or.j1+j2+j3+1<0
   *.or.abs(j1+j2+j3+1-int(j1+j2+j3+1))>0.or.j1+l2-l3<0.or.
   *abs(j1+l2-l3-int(j1+l2-l3))>0.0001.or.j1-l2+l3<0.or.
   *abs(j1-l2+l3-int(j1-l2+l3))>0.0001.or.-j1+l2+l3<0
   *.or.abs(-j1+l2+l3-int(-j1+l2+l3))>0.0001.or.j1+l2+l3+1<0.or.
   *abs(j1+l2+l3+1-int(j1+l2+l3+1))>0.0001.or.l1+j2-l3<0.or.
   *abs(l1+j2-l3-int(l1+j2-l3))>0.0001.or.l1-j2+l3<0.or.
   *abs(l1-j2+l3-int(l1-j2+l3))>0.0001.or.-l1+j2+l3<0.or.
   *abs(-l1+j2+l3-int(-l1+j2+l3))>0.0001.or.l1+j2+l3+1<0.or.
   *abs(l1+j2+l3+1-int(l1+j2+l3+1))>0.0001.or.l1+l2-j3<0.or.
   *abs(l1+l2-j3-int(l1+l2-j3))>0.0001.or.l1-l2+j3<0.or.
   *abs(l1-l2+j3-int(l1-l2+j3))>0.0001.or.-l1+l2+j3<0.or.
   *abs(-l1+l2+j3-int(-l1+l2+j3))>0.0001.or.l1+l2+j3+1<0.or.
   *abs(l1+l2+j3+1-int(l1+l2+j3+1))>0.0001) THEN
S6J=0
Else
s6j=(((p1(j1+j2-j3)*p1(j1-j2+j3)*p1(-j1+j2+j3))/p1(j1+j2+j3+1))
   * **(1.0/2.0))*(((p1(j1+l2-l3)*p1(j1-l2+l3)*p1(-j1+l2+l3))
   * /p1(j1+l2+l3+1))**(1.0/2.0))*(((p1(l1+j2-l3)*p1(l1-j2+l3)
   * *p1(-l1+j2+l3))/p1(l1+j2+l3+1))**(1.0/2.0))*(((p1(l1+l2-j3)
   * *p1(l1-l2+j3)*p1(-l1+l2+j3))/p1(l1+l2+j3+1))**(1.0/2.0))
   * *plus_sum
End if
   End Function s6j

Function p1(n)

   Real :: j1, j2, j3, l1, l2, l3, i, k,n, k1, k2
   Real*8 p1
   If (n==0) Then
   p1 = 1
   Else
   p1 = 1
   Do i = 1, n, 1
   p1 = p1*i
   End Do
   End If
   End Function p1

   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

      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人回复

1楼 2016-07-12 10:46:58

已阅回复此楼关注TA 给TA发消息送TA红花 TA的回帖

涂代洋

铁虫 (初入文坛)

应助: 0 (幼儿园)
金币: 5.3
散金: 20
帖子: 24
在线: 3.9小时
虫号: 2977137
注册: 2014-02-19
专业: 凝聚态物性 II ：电子结构

引用回帖:

2楼: Originally posted by argo at 2016-07-12 12:53:35
N为什么用real*8?

谢谢！N如果我没有用这种类型，就出现了错误提示！

赞一下

回复此楼

4楼2016-07-13 10:19:42

已阅回复此楼关注TA 给TA发消息送TA红花 TA的回帖

查看全部 7 个回答

argo

铁杆木虫 (著名写手)

上善若水

应助: 4 (幼儿园)
金币: 9672.8
散金: 200
红花: 34
帖子: 1940
在线: 486.4小时
虫号: 507533
注册: 2008-02-19
性别: GG
专业: 凝聚态物性 II ：电子结构

N为什么用real*8?

赞一下(1人)

回复此楼

居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。

2楼2016-07-12 12:53:35

已阅回复此楼关注TA 给TA发消息送TA红花 TA的回帖

argo

铁杆木虫 (著名写手)

上善若水

应助: 4 (幼儿园)
金币: 9672.8
散金: 200
红花: 34
帖子: 1940
在线: 486.4小时
虫号: 507533
注册: 2008-02-19
性别: GG
专业: 凝聚态物性 II ：电子结构

修改了N的类型，第174行代码越界，运行20分钟，没出现提示

赞一下(1人)

回复此楼

居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。

3楼2016-07-12 13:11:27

已阅回复此楼关注TA 给TA发消息送TA红花 TA的回帖

涂代洋

铁虫 (初入文坛)

应助: 0 (幼儿园)
金币: 5.3
散金: 20
帖子: 24
在线: 3.9小时
虫号: 2977137
注册: 2014-02-19
专业: 凝聚态物性 II ：电子结构

涂代洋: 回帖置顶 2016-07-14 09:38:02

引用回帖:

3楼: Originally posted by argo at 2016-07-12 13:11:27
修改了N的类型，第174行代码越界，运行20分钟，没出现提示

感谢您的回答，那怎么改呢？174行越界了，N我知道是整数型，但是我改了就出现了问题，而且这个软件不大，怎么会运行20分钟呢？每次我运行几分钟就关闭了！

赞一下

回复此楼

5楼2016-07-13 10:21:55

已阅回复此楼关注TA 给TA发消息送TA红花 TA的回帖

查看全部 7 个回答

最具人气热帖推荐 [查看全部]		作者	回/看	最后发表

[考研] 321求调剂 +5	wasdssaa 2026-03-26	5/250	2026-03-26 18:00 by fmesaito
[考研] 材料考研求调剂 +3	Dendel 2026-03-23	6/300	2026-03-26 17:51 by fmesaito
[考研] 085601求调剂总分293英一数二 +4	钢铁大炮 2026-03-24	4/200	2026-03-26 16:28 by dick_runner
[考研] 材料与化工考研调剂 +10	孅華 2026-03-22	10/500	2026-03-26 15:40 by zzll406
[考研] 总分293求调剂 +6	加一一九 2026-03-25	8/400	2026-03-26 13:30 by yujianx
[考研] 一志愿哈工大，085400，320，求调剂 +4	gdlf9999 2026-03-24	4/200	2026-03-25 23:01 by boxking200
[考研] 材料求调剂 +4	.m.. 2026-03-25	4/200	2026-03-25 21:30 by peike
[考研] 0854AI CV方向招收调剂 +4	章小鱼567 2026-03-23	4/200	2026-03-25 17:04 by CoderLoser
[考研] 各位老师您好：本人初试372分 +5	jj涌77 2026-03-25	6/300	2026-03-25 14:15 by mapenggao
[考研] 293求调剂 +7	加一一九 2026-03-24	7/350	2026-03-25 12:02 by userper
[考研] 086003食品工程求调剂 +6	淼淼111 2026-03-24	6/300	2026-03-25 10:29 by 3Strings
[考研] 考研化学308分求调剂 +10	你好明天你好 2026-03-23	11/550	2026-03-25 10:23 by userper
[考研] 300求调剂，材料科学英一数二 +5	leaflight 2026-03-24	5/250	2026-03-24 16:25 by laoshidan
[考研] 一志愿华东理工大学081700，初试分数271 +5	kotoko_ik 2026-03-23	6/300	2026-03-24 10:29 by 学术搬砖er
[考研] 一志愿北京化工大学 070300 学硕 336分求调剂 +7	vv迷 2026-03-22	7/350	2026-03-23 23:44 by Txy@872106
[考研] 化学308分求调剂 +3	你好明天你好 2026-03-23	3/150	2026-03-23 20:11 by macy2011
[考研] 308求调剂 +3	墨墨漠 2026-03-21	3/150	2026-03-22 16:54 by i_cooler
[考研] 260求调剂 +3	朱芷琳 2026-03-20	4/200	2026-03-22 15:12 by 朱芷琳
[考研] 285求调剂 +6	ytter 2026-03-22	6/300	2026-03-22 12:09 by 星空星月
[考研] 353求调剂 +3	拉钩不许变 2026-03-20	3/150	2026-03-20 19:56 by JourneyLucky