24小时热门版块排行榜

>论坛更新日志 (3228)
>虫友互识 (827)
>文献求助 (222)
>休闲灌水 (157)
>导师招生 (151)
>考博 (130)
>教师之家 (86)
>硕博家园 (80)
>博后之家 (77)
>找工作 (77)
>论文投稿 (74)
>论文道贺祈福 (67)
>基金申请 (65)
>考研 (57)
>公派出国 (51)
>招聘信息布告栏 (33)

返回列表

zhangpengju

新虫 (小有名气)

应助: 13 (小学生)
金币: 282.9
散金: 5
红花: 2
帖子: 221
在线: 170.8小时
虫号: 946738
注册: 2010-01-22
性别: GG
专业: 原子和分子物理

[求助] fortran77一段程序，求用f.90的do循环实现

SUBROUTINE APSIS(S,EREL,R)                                     AANX0639
   DOUBLE PRECISION S,EREL                                        AANX0640
   DOUBLE PRECISION R,R1,R2,R3,T1,T2,T3,TR,R0,T0,RES,DR,T12       AANX0641
C                                                                      AANX0642
C    FIND R1,R2 WITH F(R1)<0 AND F(R2)>0                            AANX0643
C                                                                      AANX0644
   IF(ABS(S).GT.1.0E-12) GOTO 50                                  AANX0645
   R0 = 1.0E-03                                                    AANX0646
   T0 = 0                                                          AANX0647
40 CONTINUE                                                       AANX0648
   CALL V(R0,RES)                                                 AANX0649
   T12 = T0                                                       AANX0650
   T0 = 1.0 - S*S/(R0*R0) - RES/EREL                               AANX0651
   IF (T0.LE.0) GOTO 100                                           AANX0652
   R0 = R0/2                                                       AANX0653
   GOTO 40                                                          AANX0654
50 R0 = ABS(S)/2.0                                                 AANX0655
   T0 = 0                                                          AANX0656
100 CONTINUE                                                       AANX0657
   R0 = R0*2                                                       AANX0658
   CALL V(R0,RES)                                                 AANX0659
   T12 = T0                                                       AANX0660
   T0 = 1.0 - S*S/(R0*R0) - RES/EREL                               AANX0661
   IF (T0.LE.0) GOTO 100                                           AANX0662
200 R1 = R0/2                                                       AANX0663
   R2 = R0                                                          AANX0664
   T1 = T12                                                       AANX0665
   T2 = T0                                                          AANX0666
C                                                                      AANX0667
C    MAIN LOOP - COMBINATION OF BISECTION AND FALSE                AANX0668
C    POSITION METHODS.                                              AANX0669
C                                                                      AANX0670
900 CONTINUE                                                       AANX0671
   R = (T2*R1-T1*R2)/(T2-T1)                                        AANX0672
   CALL V(R,RES)                                                    AANX0673
   TR = 1.0 - S*S/(R*R) - RES/EREL                                  AANX0674
   R3 = 0.5*(R1+R2)                                                 AANX0675
   CALL V(R3,RES)                                                 AANX0676
   T3 = 1.0 - S*S/(R3*R3) - RES/EREL                               AANX0677
   IF (T3.LE.0) GOTO 500                                           AANX0678
   IF (R3.LT.R) GOTO 400                                           AANX0679
   DR = R2 - R                                                    AANX0680
   R2 = R                                                          AANX0681
   T2 = TR                                                          AANX0682
   GOTO 600                                                       AANX0683
400 DR = R2 - R3                                                    AANX0684
   R2 = R3                                                          AANX0685
   T2 = T3                                                          AANX0686
   GOTO 600                                                       AANX0687
500 CONTINUE                                                       AANX0688
   R1 = R3                                                          AANX0689
   T1 = T3                                                          AANX0690
   DR = R - R2                                                    AANX0691
   R2 = R                                                          AANX0692
   T2 = TR                                                          AANX0693
600 CONTINUE                                                       AANX0694
   IF((ABS(DR).GT.1.0E-15).OR.(ABS(TR).GT.1.0E-15)) GOTO 900       AANX0695
   RETURN                                                          AANX0696
   END

回复此楼