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

24小时热门版块排行榜    

小木虫论坛-学术科研互动平台 » 专业学科区 » 物理 » 凝聚态物理 » fortran编程超出边界问题
71/1返回列表
查看: 1329  |  回复: 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的回帖

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的回帖

涂代洋

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

铁杆木虫 (著名写手)

上善若水
内容已删除
回复此楼
居善地，心善渊，与善仁，言善信，正善治，事善能，动善时。
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返回列表
普通表情 龙 兔 虎 猫
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[基金申请] 科研孤儿太难了 +9 我4大白菜 2026-08-20 9/450 2026-08-20 18:23 by 2549091707
[基金申请] 时间戳变了，能看出什么问题？ +18 基诺咪客 2026-08-17 23/1150 2026-08-20 17:19 by Godzela
[基金申请] 今天系统多次维护，明天很可能放榜！ +9 zju2000 2026-08-16 10/500 2026-08-20 15:56 by Leogzhya
[基金申请] 放榜前的不淡定 40+3 snowwithsea 2026-08-19 12/600 2026-08-20 15:56 by lfy8008
[基金申请] 言之凿凿，明天官网会通知放榜？ +14 医学老男孩 2026-08-20 16/800 2026-08-20 15:47 by LNP@mRNA
[基金申请] 重要消息，中午系统在维护 +11 yuleib84 2026-08-18 12/600 2026-08-20 11:09 by xskun
[基金申请] 哪位老哥知道今年的国自然具体哪一天放榜？ +16 Ldrop2023 2026-08-13 20/1000 2026-08-20 11:07 by xskun
[基金申请] 今天基金会出结果吗？20260819 +14 kkkl_v 2026-08-19 15/750 2026-08-20 08:21 by sunzitan
[基金申请] filecode，4个jtjc了 +11 ziyangfang 2026-08-19 13/650 2026-08-19 21:28 by aasahr
[教师之家] 为什么余额宝的年化利率越来越低？主要原因有哪些？ +5 瞬息宇宙 2026-08-15 5/250 2026-08-19 20:23 by super2002521
[基金申请] 今天放榜没戏了吧 +4 yuleib84 2026-08-19 5/250 2026-08-19 19:52 by hhs666
[基金申请] 今天放榜吗？ +14 布布和一二 2026-08-19 15/750 2026-08-19 18:07 by gltch
[基金申请] filecode=后面第一个是大写字母 +10 wangze12014 2026-08-14 12/600 2026-08-19 16:56 by 苦难博士
[基金申请] 2027广东省杰青 +4 奶牛小黑 2026-08-15 10/500 2026-08-19 11:02 by wanfengnew
[基金申请] 朋友圈看到的 +6 wangzilk 2026-08-18 8/400 2026-08-19 10:55 by Haru815
[基金申请] 快农历七夕节了，轻松一下，男人悄悄话，女施主请不要进来。 +6 Tide man 2026-08-14 7/350 2026-08-19 09:56 by ZJTJZ
[基金申请] 明天放榜？ +5 Shxjjxjkx 2026-08-18 5/250 2026-08-18 18:14 by -大大大大大-
[论文投稿] 投稿咨询 +4 wwm09 2026-08-17 6/300 2026-08-18 15:36 by wwm09
[精细化工] 招聘 金属平磨液，抛光液研发工程师 +3 小天0311 2026-08-14 3/150 2026-08-16 07:31 by H9PLUS
[基金申请] 各位道友，我要去昆明玩几天，回来见。 +7 Tide man 2026-08-14 8/400 2026-08-15 01:11 by arzu_hma
信息提示
关闭
请填处理意见
关闭