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

24小时热门版块排行榜    

小木虫论坛-学术科研互动平台 » 计算模拟区 » 计算模拟 » 【求助】帮忙修改用powell方法解题的fortran程序
北京石油化工学院2026年研究生招生接收调剂公告
31/1返回列表
查看: 389  |  回复: 2
只看楼主 @他人 存档 新回复提醒 (忽略) 收藏    在APP中查看
当前主题已经存档。

329543477

木虫 (正式写手)

[交流] 【求助】帮忙修改用powell方法解题的fortran程序

利用所给的powell方法求解如下函数的极小值点：f(x1,x2)=(x1+x2)**2+(x1-1)**2
初始点为列矩阵（2，1），搜索方法为（1，0）（0，1）
powell方法的程序如下：
   SUBROUTINE POWELL(P,XI,N,NP,FTOL,ITER,FRET)
      PARAMETER (NMAX=20,ITMAX=200)
      DIMENSION P(NP),XI(NP,NP),PT(NMAX),PTT(NMAX),XIT(NMAX)
      FRET=FUNC(P)
      DO 11 J=1,N
        PT(J)=P(J)
11    CONTINUE
      ITER=0
1     ITER=ITER+1
      FP=FRET
      IBIG=0
      DEL=0.
      DO 13 I=1,N
        DO 12 J=1,N
          XIT(J)=XI(J,I)
12      CONTINUE
        CALL LINMIN(P,XIT,N,FRET)
        IF(ABS(FP-FRET).GT.DEL)THEN
          DEL=ABS(FP-FRET)
          IBIG=I
        ENDIF
13    CONTINUE
      IF(2.*ABS(FP-FRET).LE.FTOL*(ABS(FP)+ABS(FRET)))RETURN
      IF(ITER.EQ.ITMAX) PAUSE 'Powell exceeding maximum iterations.'
      DO 14 J=1,N
        PTT(J)=2.*P(J)-PT(J)
        XIT(J)=P(J)-PT(J)
        PT(J)=P(J)
14    CONTINUE
      FPTT=FUNC(PTT)
      IF(FPTT.GE.FP)GO TO 1
      T=2.*(FP-2.*FRET+FPTT)*(FP-FRET-DEL)**2-DEL*(FP-FPTT)**2
      IF(T.GE.0.)GO TO 1
      CALL LINMIN(P,XIT,N,FRET)
      DO 15 J=1,N
        XI(J,IBIG)=XIT(J)
15    CONTINUE
      GO TO 1
      END

      FUNCTION BRENT(AX,BX,CX,F,TOL,XMIN)
      PARAMETER (ITMAX=100,CGOLD=.3819660,ZEPS=1.0E-10)
      A=MIN(AX,CX)
      B=MAX(AX,CX)
      V=BX
      W=V
      X=V
      E=0.
      FX=F(X)
      FV=FX
      FW=FX
      DO 11 ITER=1,ITMAX
        XM=0.5*(A+B)
        TOL1=TOL*ABS(X)+ZEPS
        TOL2=2.*TOL1
        IF(ABS(X-XM).LE.(TOL2-.5*(B-A))) GOTO 3
        IF(ABS(E).GT.TOL1) THEN
          R=(X-W)*(FX-FV)
          Q=(X-V)*(FX-FW)
          P=(X-V)*Q-(X-W)*R
          Q=2.*(Q-R)
          IF(Q.GT.0.) P=-P
          Q=ABS(Q)
          ETEMP=E
          E=D
          IF(ABS(P).GE.ABS(.5*Q*ETEMP).OR.P.LE.Q*(A-X).OR.
     *        P.GE.Q*(B-X)) GOTO 1
          D=P/Q
          U=X+D
          IF(U-A.LT.TOL2 .OR. B-U.LT.TOL2) D=SIGN(TOL1,XM-X)
          GOTO 2
        ENDIF
1       IF(X.GE.XM) THEN
          E=A-X
        ELSE
          E=B-X
        ENDIF
        D=CGOLD*E
2       IF(ABS(D).GE.TOL1) THEN
          U=X+D
        ELSE
          U=X+SIGN(TOL1,D)
        ENDIF
        FU=F(U)
        IF(FU.LE.FX) THEN
          IF(U.GE.X) THEN
            A=X
          ELSE
            B=X
          ENDIF
          V=W
          FV=FW
          W=X
          FW=FX
          X=U
          FX=FU
        ELSE
          IF(U.LT.X) THEN
            A=U
          ELSE
            B=U
          ENDIF
          IF(FU.LE.FW .OR. W.EQ.X) THEN
            V=W
            FV=FW
            W=U
            FW=FU
          ELSE IF(FU.LE.FV .OR. V.EQ.X .OR. V.EQ.W) THEN
            V=U
            FV=FU
          ENDIF
        ENDIF
11    CONTINUE
      PAUSE 'Brent exceed maximum iterations.'
3     XMIN=X
      BRENT=FX
      RETURN
      END

      FUNCTION F1DIM(X)
      PARAMETER (NMAX=50)
      COMMON /F1COM/ NCOM,PCOM(NMAX),XICOM(NMAX)
      DIMENSION XT(NMAX)
       DO 11 J=1,NCOM
        XT(J)=PCOM(J)+X*XICOM(J)
11    CONTINUE     
      F1DIM=FUNC(XT)
      RETURN
      END

      SUBROUTINE LINMIN(P,XI,N,FRET)
      PARAMETER (NMAX=50,TOL=1.E-4)
      EXTERNAL F1DIM
      DIMENSION P(N),XI(N)
      COMMON /F1COM/ NCOM,PCOM(NMAX),XICOM(NMAX)
      NCOM=N
      DO 11 J=1,N
        PCOM(J)=P(J)
        XICOM(J)=XI(J)
11    CONTINUE
      AX=0.
      XX=1.
      BX=2.
      CALL MNBRAK(AX,XX,BX,FA,FX,FB,F1DIM)
      FRET=BRENT(AX,XX,BX,F1DIM,TOL,XMIN)
      DO 12 J=1,N
        XI(J)=XMIN*XI(J)
        P(J)=P(J)+XI(J)
12    CONTINUE
      RETURN
      END

      SUBROUTINE MNBRAK(AX,BX,CX,FA,FB,FC,FUNC)
      PARAMETER (GOLD=1.618034, GLIMIT=100., TINY=1.E-20)
      FA=FUNC(AX)
      FB=FUNC(BX)
      IF(FB.GT.FA)THEN
        DUM=AX
        AX=BX
        BX=DUM
        DUM=FB
        FB=FA
        FA=DUM
      ENDIF
      CX=BX+GOLD*(BX-AX)
      FC=FUNC(CX)
1     IF(FB.GE.FC)THEN
        R=(BX-AX)*(FB-FC)
        Q=(BX-CX)*(FB-FA)
        U=BX-((BX-CX)*Q-(BX-AX)*R)/(2.*SIGN(MAX(ABS(Q-R),TINY),Q-R))
        ULIM=BX+GLIMIT*(CX-BX)
        IF((BX-U)*(U-CX).GT.0.)THEN
          FU=FUNC(U)
          IF(FU.LT.FC)THEN
            AX=BX
            FA=FB
            BX=U
            FB=FU
            GO TO 1
          ELSE IF(FU.GT.FB)THEN
            CX=U
            FC=FU
            GO TO 1
          ENDIF
          U=CX+GOLD*(CX-BX)
          FU=FUNC(U)
        ELSE IF((CX-U)*(U-ULIM).GT.0.)THEN
          FU=FUNC(U)
          IF(FU.LT.FC)THEN
            BX=CX
            CX=U
            U=CX+GOLD*(CX-BX)
            FB=FC
            FC=FU
            FU=FUNC(U)
          ENDIF
        ELSE IF((U-ULIM)*(ULIM-CX).GE.0.)THEN
          U=ULIM
          FU=FUNC(U)
        ELSE
          U=CX+GOLD*(CX-BX)
          FU=FUNC(U)
        ENDIF
        AX=BX
        BX=CX
        CX=U
        FA=FB
        FB=FC
        FC=FU
        GO TO 1
      ENDIF
      RETURN
      END




自己尝试编写的球目标函数的程序如下：
    parameter(ndim=2,ftol=1.e-6)
        real xi(ndim,ndim),pp(ndim)
        data xi/1,0,0,1/
        data pp/2.,1./
        np=ndim
        call powell(pp,xi,ndim,np,ftol,iter,fret)
        print *,pp
        print *,'fret=',fret
        end

      function f(x1,x2)
        real x1,x2,f(x1,x2)
      f(x1,x2)=(x1+x2)**2+(x1-1)**2
      end

求助高手指点，程序改怎么修改？

[ Last edited by dongdong3881 on 2009-12-12 at 09:24 ]
回复此楼

» 猜你喜欢
“博观而约取，厚积而薄发”——苏东坡
1楼 2009-09-01 16:55:23
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

329543477

木虫 (正式写手)
有fortran高手加我QQ：329543477
赞一下 回复此楼
“博观而约取，厚积而薄发”——苏东坡
2楼2009-09-01 16:59:39
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖

329543477

木虫 (正式写手)
已经解决，请斑竹帮忙收回BB,谢谢。O(∩_∩)O~
赞一下 回复此楼
“博观而约取，厚积而薄发”——苏东坡
3楼2009-09-05 19:59:37
已阅   回复此楼   关注TA 给TA发消息 送TA红花 TA的回帖
相关版块跳转 我要订阅楼主 329543477 的主题更新
31/1返回列表
普通表情 龙 兔 虎 猫 高级回复 (可上传附件)
最具人气热帖推荐 [查看全部] 作者 回/看 最后发表
[考研] 环境285分，过六级，求调剂 +7 xhr12 2026-04-02 7/350 2026-04-02 22:45 by chran16
[考研] 交通运输考试264分求工科调剂 +4 jike777 2026-04-02 4/200 2026-04-02 21:53 by zllcz
[考研] 环境科学与工程334分求调剂 +7 王一一依依 2026-03-30 9/450 2026-04-02 21:15 by 1104338198
[考研] 298求调剂 +4 zzz，，r 2026-04-02 7/350 2026-04-02 18:57 by 1939136013狗壮
[考研] 362求调剂 +14 西南交材料专硕3 2026-03-31 14/700 2026-04-02 17:50 by yunlongyang
[考研] 化学308分调剂 +14 你好明天你好 2026-03-30 15/750 2026-04-02 13:39 by 嘻嘻笑22
[考研] 266分，一志愿电气工程，本科材料，求材料专业调剂 +4 哇呼哼呼哼 2026-04-02 4/200 2026-04-02 13:10 by yulian1987
[考研] 求调剂！生物与医药专硕 +4 逆转陆先生 2026-04-01 4/200 2026-04-02 11:51 by xiaoranmu
[考研] 【求调剂】新能源材料本科，一志愿211，初试321 +6 求调剂学校， 2026-04-02 6/300 2026-04-02 09:41 by 晴空210210
[考研] 英一数一408，总分284，二战真诚求调剂 +12 12.27 2026-03-30 14/700 2026-04-02 00:18 by 欣喜777
[考研] 江苏科技大学招材料研究生 +4 Su032713. 2026-04-01 5/250 2026-04-01 22:03 by cccchenso
[考研] 材料科学与工程339求调剂 +11 hyz0119 2026-03-31 12/600 2026-04-01 18:40 by 伟大河北
[考研] 353求调剂 +4 拉钩不许变 2026-04-01 4/200 2026-04-01 18:10 by 记事本2026
[考研] 生物与医药考研调剂 +5 铁憨憨123425 2026-03-31 5/250 2026-04-01 18:01 by syh9288
[考研] 086000生物与医药298调剂求助 +4 元元青青 2026-03-31 6/300 2026-04-01 11:13 by syh9288
[考研] 08工科，295，接受跨专业调剂 +6 lmnlzy 2026-03-31 6/300 2026-04-01 11:02 by 逆水乘风
[考研] 322求调剂 +8 三水sss 2026-04-01 8/400 2026-04-01 10:19 by 唐沐儿
[考研] 一志愿 南京航空航天大学 ，080500材料科学与工程学硕 +10 @taotao 2026-03-31 11/550 2026-04-01 09:43 by xiayizhi
[考研] 317分 一志愿南理工材料工程 本科湖工大 求调剂 +12 芋泥小铃铛 2026-03-28 12/600 2026-03-30 17:06 by wangjy2002
[考研] 材料与化工（0856）304求B区调剂 +8 邱gl 2026-03-27 8/400 2026-03-28 12:42 by 唐沐儿
信息提示
关闭
请填处理意见
关闭