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

24小时热门版块排行榜    

小木虫论坛-学术科研互动平台 » 专业学科区 » 物理 » 凝聚态物理 » fortran编程超出边界问题
71/1返回列表
查看: 1192  |  回复: 6
只看楼主 @他人 存档 新回复提醒 (忽略) 收藏    在APP中查看

涂代洋

铁虫 (初入文坛)

[求助] 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
回复此楼

» 猜你喜欢
1楼 2016-07-12 10:46:58
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
回帖置顶 ( 共有1个 )

涂代洋

铁虫 (初入文坛)
涂代洋: 回帖置顶 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的回帖
普通回帖

argo

铁杆木虫 (著名写手)

上善若水
N为什么用real*8?
赞一下(1人) 回复此楼
居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。
2楼2016-07-12 12:53:35
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

argo

铁杆木虫 (著名写手)

上善若水
修改了N的类型，第174行代码越界，运行20分钟，没出现提示
赞一下(1人) 回复此楼
居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。
3楼2016-07-12 13:11:27
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

涂代洋

铁虫 (初入文坛)
引用回帖:
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的回帖

argo

铁杆木虫 (著名写手)

上善若水
内容已删除
回复此楼
居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。
6楼2016-07-15 18:50:42
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

涂代洋

铁虫 (初入文坛)
引用回帖:
6楼: Originally posted by argo at 2016-07-15 18:50:42
怎么改类型你都不知道？第二行最后的逗号和N去掉就可以了！
越界，代码变绿色，在CVF中，那一行前面的空格去掉几个就可以了。最基本的编程序规则还是找本书翻一翻吧。

你出错的提示要帖出来，要不然别人看不出 ...

我试了没用出错，但是就是没用跑出来！
赞一下 回复此楼
7楼2016-07-16 11:08:28
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
相关版块跳转 我要订阅楼主 涂代洋 的主题更新
71/1返回列表
普通表情 龙 兔 虎 猫
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[考研] 材料考研求调剂 +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
[考研] 22 350 本科985求调剂，求老登收留 +4 李轶男003 2026-03-20 4/200 2026-03-26 16:05 by 哇啦啦啦xtj
[考研] 279 分 求调剂 +3 睡个好觉_16 2026-03-24 3/150 2026-03-26 15:43 by zzll406
[考研] 一志愿 西北大学 ，070300化学学硕，总分287，双非一本，求调剂。 +5 晨昏线与星海 2026-03-20 5/250 2026-03-26 13:47 by 一直走不要停
[考研] 一志愿哈工大，085400，320，求调剂 +4 gdlf9999 2026-03-24 4/200 2026-03-25 23:01 by boxking200
[考研] 求调剂 +3 QiMing7 2026-03-25 3/150 2026-03-25 21:13 by 给你你注意休息
[考研] 289求调剂 +9 怀瑾握瑜l 2026-03-20 9/450 2026-03-25 11:02 by userper
[考研] 299求调剂 +7 shxchem 2026-03-20 9/450 2026-03-25 10:41 by lbsjt
[考研] 318求调剂 +5 plum李子 2026-03-21 8/400 2026-03-25 09:26 by aa331100
[考研] 一志愿武理085500机械专业总分300求调剂 +3 an10101 2026-03-24 7/350 2026-03-25 00:00 by 山鬼0-
[考研] 292求调剂 +4 鹅鹅鹅额额额额� 2026-03-24 4/200 2026-03-24 16:41 by peike
[考研] 求调剂 +7 十三加油 2026-03-21 7/350 2026-03-23 23:48 by 热情沙漠
[考研] 一志愿国科过程所081700，274求调剂 +3 三水研0水立方 2026-03-23 3/150 2026-03-23 23:11 by MajorWen
[考研] 333求调剂 +3 ALULU4408 2026-03-23 3/150 2026-03-23 19:04 by macy2011
[考研] 一志愿东华大学化学070300，求调剂 +7 2117205181 2026-03-21 8/400 2026-03-22 22:55 by chixmc
[考研] 319求调剂 +4 小力气珂珂 2026-03-20 4/200 2026-03-22 15:53 by ColorlessPI
[考研] 269专硕求调剂 +6 金恩贝 2026-03-21 6/300 2026-03-22 14:31 by ColorlessPI
[考研] 295复试调剂 +8 简木ChuFront 2026-03-19 8/400 2026-03-20 20:44 by zhukairuo
[考研] 求调剂 +3 eation27 2026-03-20 3/150 2026-03-20 19:32 by JourneyLucky
信息提示
关闭
请填处理意见
关闭